                   V. A.  C R O S S  R E F E R E N C E R  7.3
                       [2008 VA Standards & Conventions]
                  UCI: VISTA CPU: ROU    Jul 01, 2016@13:24:55

The BUILD file Data Dictionaries are being processed.

53.8 CLOZAPINE MEDICATION OVERRIDES.......
55.06 UNIT DOSE
The option and function files are being processed.


Routines are being processed.
Routines: 22  Faux Routines: 3

PSGNE3    PSGOD     PSGOE41   PSGOE42   PSGOE7    PSGOE8    PSGOE81   PSGOE82   
PSGOE92   PSGOEF    PSGOER    PSGOER0   PSGOESF   PSGOEV    PSGOT     PSGPEN    
PSJCLOLS  PSJCLOZ   PSJCOM    PSJOE     PSJOE1    PSJRXLAB  

          Data Dictionaries
|dd53.8        |dd55.06       |opt           

--- CROSS REFERENCING ---


Compiled list of Errors and Warnings              Jul 01, 2016@13:24:55 page 1
No errors or warnings to report


--- Routine Detail   --- with REGULAR ROUTINE LISTING ---

PSGNE3   * *  195 Lines,  10657 Bytes, Checksum: B89726178
                                                  Jul 01, 2016@13:24:55 page 2
              932 bytes in comments
PSGNE3   ;BIR/CML3,MLM-DETERMINE DEFAULT FOR START & STOP TIMES ; 12/13/10 2:46p
          m
         ;;5.0;INPATIENT MEDICATIONS ;**4,26,47,50,63,69,105,80,111,183,193,179,
          275,327**;16 DEC 97;Build 10
         ;
         ; Reference to ^PS(51.1 is supported by DBIA 2177
         ; Reference to ^PS(55 is supported by DBIA 2191
         ; Reference to PSBAPIPM is supported by DBIA 3564
         ;
         N X1,X2,Y
NOW      ;
         S:'$D(PSGST) PSGST=""
         S PSGDT=$$DATE^PSJUTL2(),PSGNESD=$$ENSD($S(PSGST["P":"PRN",1:PSGSCH),PS
          GS0Y,PSGDT,PSGDT)
         ;
STOP     ; exit when start date found
         K ET,F,FT,LT,NT,PSGNE3,TT G:$D(PSGOES)!$D(PSGODF) SF S PSGNESDO=$$ENDD^
          PSGMI(PSGNESD)
         Q
         ;
ENFD(PSGDT) --
          ; find default stop date
         N X1,X2,X3DMIN,Y
SF       I '$O(^PS(55,PSGP,5,"AUS",PSGDT)),'$D(^PS(53.1,"AC",PSGP)),+$G(^PS(55,P
          SGP,5.1)) S $P(^PS(55,PSGP,5.1),U)=""
         S PSJSYSW0=$G(PSJSYSW0) ; Initialize/restore PSJSYSW0 ward parameters; 
          clinic orders may not have them. Killed at exit in ENKV^PSGSETU
         I $G(PSGOEA)="R",$P(PSJSYSW0,"^",4) D ENWALL(%,0,PSGP)
         S PSGNEFD="",PSGNEW=$S('$P(PSJSYSW0,U,4):0,+$G(^PS(55,PSGP,5.1))'>PSGDT
          :0,1:+$G(^PS(55,PSGP,5.1))) S:PSGNEW<PSGNESD PSGNEW=0
         I PSGNEW,($G(PSGOEA)="R") S X1=$P(%,"."),X2=3 D C^%DTC S PSGNEW=$S($P(X
          ,".")_(PSGNESD#1)'>PSGNEW:PSGNEW,1:0)
         I PSGST="O" S PSGNEFD=$$ENOSD^PSJDCU(PSJSYSW0,PSGNESD,PSGP) I PSGNEFD]"
          " G OUT
         ;PSJ*179;x-ref to "APPSJ"
         I PSGST'="O",PSGSCH]"",$S(PSGSCH="ONCE":1,PSGSCH="STAT":1,PSGSCH="ONE T
          IME":1,1:0)!($P($G(^PS(51.1,+$O(^PS(51.1,"AC","PSJ",PSGSCH,0)),0)),"^"
          ,5)="O") S PSGNEFD=$$ENOSD^PSJDCU(PSJSYSW0,PSGNESD,PSGP) I PSGNEFD]"" 
          G OUT
         S X1=$P(PSGNESD,"."),X2=$S($P(PSJSYSW0,"^",3):+$P(PSJSYSW0,"^",3),1:14)
         D
         . ; *** psi 06 082 - RDC 08/2006;ADDED VAR AA TO CHK FOR APPT and CLINI
          C ***
         . N A,AA,B
         . Q:'$D(PSGORD)  S A=""
         . I PSGORD["P" S A=$G(^PS(53.1,+PSGORD,"DSS"))
         . I PSGORD["U" S A=$G(^PS(55,PSGP,5,+PSGORD,8))
         . I PSGORD["I" S A=$G(^PS(55,PSGP,"IV",+PSGORD,"DSS"))
         . ;PSJ*5*179;Clin Def Stop
         . S AA=$P(A,"^",2),A=$P(A,"^") I A,AA S X2=14 I $D(^PS(53.46,"B",A)) S 
          B=$O(^PS(53.46,"B",A,"")),X2=$P(^PS(53.46,B,0),"^",2) I X2="" S X2=14
         D C^%DTC
         I $G(PSGNEDFD) I $S($P(PSGNEDFD,"^")["L":PSGS0XT!PSGS0Y,1:1) D DFD
         I $G(PSGORD),$G(PSGFD) S X3DMIN=$$GETDUR^PSJLIVMD(PSGP,+$G(PSGORD),$S($
          G(PSGORD)["P":"P",$G(PSGORD)["V":"IV",1:5),1) I X3DMIN]"" D  I PSGNEFD
          ]"" G OUT
         . S X3DMIN=$$DURMIN^PSJLIVMD(X3DMIN) I $G(X3DMIN) S PSGNEFD=$$FMADD^XLF
          DT(PSGNESD,,,X3DMIN)
         S X=+(X_$S($P(PSJSYSW0,"^",7):"."_$P(PSJSYSW0,"^",7),1:(PSGNESD#1)))
         ;; START NCC REMEDIATION >> 327*RJS
         I +$G(CLOZPAT) D
         .N X,X1,X2,X3 S X3=$G(PSGNESD),X1=X3,X2=$S($G(CLOZPAT)=2:28,$G(CLOZPAT)
          =1:14,$G(CLOZPAT)=0:7,1:90) D C^%DTC S PSGNEFD=X
         S:'+$G(CLOZPAT) PSGNEFD=$S('PSGNEFD:X,X<PSGNEFD:X,1:PSGNEFD)
         I PSGNEW,(PSGNEW<PSGNEFD),$P(PSJSYSW0,U,4) D
         . I $G(PSGORD),$G(PSGRDTX) I PSGORD=$P(PSGRDTX,U,4),PSGNEW<PSGRDTX Q   
          ; Requested Start is after Stop
         . S PSGNEFD=PSGNEW
         ;; END NCC REMEDIATION >> 327*RJS
         ;
OUT      ;
         ;*179 Account for drug changing
         I $G(PSGPDNX)&('$G(PSBSTR)) S:$G(PSGSDX) PSGNESD=PSGSDX S:$G(PSGFDX) PS
          GNEFD=PSGFDX
         I '$D(PSGODF),'$D(PSGOES) S PSGNEFDO=$$ENDD^PSGMI(PSGNEFD)
         K PSGDL,PSGNEW Q
         ;
DFD      ;
         I $P(PSGNEDFD,"^")["D" S X1=$P(PSGNESD,"."),X2=+PSGNEDFD D C^%DTC S X=+
          (X_"."_$S($P(PSJSYSW0,"^",7):$P(PSJSYSW0,"^",7),1:$P(PSGNESD,".",2)))
         I $P(PSGNEDFD,"^")["L" S PSGDL=+PSGNEDFD D EN1^PSGDL
         S PSGNEFD=$S(PSGNEW<X&PSGNEW:PSGNEW,1:X) Q:$P(PSGNEDFD,"^")'["D"!'$P(PS
          JSYSW0,"^",4)!PSGNEW
         Q
         ;
ENOR     ;
         K PSGOES,PSGODF S X=$P($G(^PS(53.1,DA,2)),"^")
         S $P(^PS(53.1,DA,0),"^",7)=$S(X="PRN":"P",X="ONCE":"O",X="STAT":"O",X="
          ONE TIME":"O",X="ON CALL":"OC",$P(PSGNEDFD,"^",3)]"":$P(PSGNEDFD,"^",3
          ),1:"C") D PSGNE3 S X=PSGNESD
         Q
         ;
ENSET0(DFN) --
          ; Set "0" node and build xrefs for entries found without one.
         N DA,DIK S ^PS(55,DFN,0)=DFN,DIK="^PS(55,",DIK(1)=.01,DA=DFN D EN^DIK
         S $P(^PS(55,DFN,5.1),"^",11)=2 ; Mark as converted for POE
         Q
         ;
ENWALL(SD,FD,DFN) --
          ; Update default stop date if appropriate.
         N WALL,NWALL,X1,X2,X3
         D NOW^%DTC S X3=%
         S WALL=+$G(^PS(55,DFN,5.1)),X1=$P(SD,"."),X2=3 D C^%DTC I +(X_"."_$P(SD
          ,".",2))'>+WALL Q
         S X1=$P(X3,"."),X2=$S($P(PSJSYSW0,U,3):+$P(PSJSYSW0,U,3),1:14) D C^%DTC
         S NWALL=X_$S($P(PSJSYSW0,U,7):"."_$P(PSJSYSW0,U,7),1:SD#1)
         S $P(^PS(55,DFN,5.1),U)=+$S(FD>NWALL:FD,1:NWALL)
         Q
         ;
ENSD(SCH,AT,LI,OSD) --
          ;Find start dt/tm
         ;SCH=schedule,AT=admin times,LI=login date/time,OSD=Renewed orders star
          t
         I $G(APPT),$G(PSGORD)["P" S XD=$$DATE2^PSJUTL2($S(($$FMDIFF^XLFDT(APPT,
          PSGDT,2)<0):PSGDT,1:APPT)) Q XD
         N X,OSDLI D
         .I $L(LI)<13 S X=LI Q
         .I $L(LI)=14 S X=$E(LI,13,14) S:X>29 X=$E(LI,1,12)_5 S:X'>29 X=$E(LI,1,
          12)_1 Q
         .I $L(LI)=13 S X=$E(LI,13)_0 S:X>29 X=$E(LI,1,12)_5 S:X'>29 X=$E(LI,1,1
          2)_1 Q
         I $G(LI) S:(LI=$G(OSD)) OSDLI=1
         S LI=+$FN(X,"",4) I '$P(LI,".",2) S LI=$$FMADD^XLFDT(LI,-1,0,0,0)_.24
         I $G(OSDLI) S OSD=LI K OSDLI
         ;BHW;PSJ*5*179;Re-calc Start date
         N PSGBCADM,PSGBCLDT,PSGBCLA,PSGBCFR,PSGBTT,PSGBST,PSGBCSHH,PSGBCLHH,PSG
          BSAT,PSGBSATN,PSGBNAT,PSGBCLIT,PSGBCTDY
         N PSGBCTDD,PSGBCTDA,PSGDAYC,PSGBDNXT,PSGBCSCD,PSGBCLID
         S (PSGBST,PSGBCFR,PSGBCADM)=""
         S PSGBCORD=$S($G(PSGORD):PSGORD,$G(PSJORD):PSJORD,1:$G(PSGORD))
         I PSGBCORD S:'$P($G(^PS(55,DFN,$S($G(PSGBCORD)["V":"IV",1:5),+PSGBCORD,
          0)),"^",2) PSGBCORD=""
         I PSGBCORD["U" S PSGBCOT=5,PSGBCND=0,PSGBCPO=25
         I PSGBCORD["V" S PSGBCOT="IV",PSGBCND=2,PSGBCPO=5
         I (PSGBCORD'["U")&(PSGBCORD'["V") S PSGBCORD=""
         I +$G(DFN)&(+PSGBCORD) S PSGBCPRV=PSGBCORD D
         .F  S PSGBCADM=$$EN^PSBAPIPM(DFN,PSGBCPRV) Q:PSGBCADM'=""  S PSGBCPRV=$
          P(^PS(55,DFN,PSGBCOT,+PSGBCPRV,PSGBCND),U,PSGBCPO) Q:(PSGBCPRV="")!(PS
          GBCPRV["P")
         .Q
         I $L(PSGBCADM) D  I PSGBST Q +PSGBST
         .S PSGBCLID=$P(LI,".",1),PSGBCLIT=$E($P(LI,".",2),1,2) I $L(PSGBCLIT)=1
           S PSGBCLIT=PSGBCLIT*10
         .S PSGBCSCH=$P(PSGBCADM,U,1),PSGBCSCD=$P(PSGBCSCH,".",1),PSGBCLDT=$P(PS
          GBCADM,U,2),PSGBCLA=$P(PSGBCADM,U,3)
         .I "GR"'[PSGBCLA Q
         .S PSGBCFR=""
         .I PSGBCORD["U" S PSGBCFR=$P(^PS(55,DFN,5,+PSGBCORD,2),U,6)
         .I PSGBCORD["V" S PSGBCFR=$P(^PS(55,DFN,"IV",+PSGBCORD,0),U,15)
         .;Convert
         .S PSGBCFR=$S(PSGBCFR="D":1440,PSGBCFR="O":0,1:PSGBCFR)*60
         .I 'PSGBCFR,'AT Q
         .S X=PSGBCSCH D H^%DTC S PSGBCSCH=%H*86400+%T,PSGBCSHH=%H_","_%T
         .S X=PSGBCLDT D H^%DTC S PSGBCLDT=%H*86400+%T,PSGBCLHH=%H_","_%T
         .;Sched Admin Time
         .I PSGBCSCH D
         ..;Check admin times/freq
         ..I AT D  Q:PSGBST
         ...S PSGBSAT=$P($P(PSGBCADM,"^",1),".",2) Q:'PSGBSAT
         ...I $L(PSGBSAT)=1 S PSGBSAT=PSGBSAT*10
         ...I ((PSGBSAT<PSGBCLIT)!(PSGBCSCD<PSGBCLID))&(PSGBCSCD'>PSGBCLID) S PS
          GBSAT=PSGBCLIT  ;&(PSGBCFR<86400)
         ...S PSGBNAT=""
         ...I ($L($P(AT,"-",1))=4)&($L(PSGBSAT)'=4) S PSGBSAT=PSGBSAT_$E("00",1,
          4-$L(PSGBSAT))
         ...F PSGBSATN=1:1 S PSGBNAT=$P(AT,"-",PSGBSATN) Q:PSGBNAT=""  I PSGBNAT
          >PSGBSAT Q
         ...;If DOW
         ...I ("SU-MO-TU-WE-TH-FR-SA"[$P(SCH,"-",1)) D  Q:PSGBST
         ....;Get TODAY
         ....D NOW^%DTC I '$L(PSGBNAT),PSGBCSCD'<X S X1=X,X2=1 D C^%DTC
         ....S PSGBCTDD=X D DW^%DTC S PSGBCTDY=$E(X,1,2)
         ....K PSGBCTMP F PSGBCTMP="SU:1","MO:2","TU:3","WE:4","TH:5","FR:6","SA
          :7" S PSGBCTMP($P(PSGBCTMP,":",1))=$P(PSGBCTMP,":",2),PSGBCTMP($P(PSGB
          CTMP,":",2))=$P(PSGBCTMP,":",1)
         ....;DAY of Last Admin
         ....S X=PSGBCSCD D DW^%DTC S PSGBCTDA=$E(X,1,2) I PSGBCSCD<PSGBCTDD S P
          SGBCTDA=PSGBCTDY
         ....;Get Next Day in Sched
         ....S PSGDAYC=PSGBCTMP(PSGBCTDA),(PSGBDNXT,X)=""
         ....F X=PSGDAYC:1:7 I SCH[$G(PSGBCTMP(X)) S PSGBDNXT=PSGBCTMP(X) Q
         ....I '$L(PSGBDNXT) S PSGBDNXT=$P(SCH,"-",1)
         ....;Set new Start Day
         ....S PSGBCTDY=PSGBCTMP(PSGBCTDY)
         ....S PSGBDNXT=PSGBCTMP(PSGBDNXT)
         ....S X2=PSGBDNXT-PSGBCTDY I X2<0 S X2=(7-PSGBCTDY)+PSGBDNXT
         ....S X1=PSGBCTDD D C^%DTC  ;Add # of days
         ....I +X S PSGBST=X_"."_($S('$L(PSGBNAT)!(PSGBCLID'=X):$P(AT,"-",1),1:P
          SGBNAT))
         ....Q
         ...;IF no Next Admin
         ...I (('PSGBNAT)&(PSGBCFR))!((PSGBCFR>86399)&(PSGBCSCD<PSGBCLID)) S X1=
          $S(PSGBCFR<86400:PSGBCLID,1:PSGBCSCD),X2=$S(PSGBCFR<86400:1,1:PSGBCFR/
          60/60/24) D C^%DTC S PSGBST=+X_"."_($S(PSGBNAT:PSGBNAT,1:$P(AT,"-",1))
          ) Q
         ...S PSGBST=PSGBCSCD_"."_PSGBNAT
         ...Q
         ..I 'PSGBCFR Q
         ..;Add Freq
         ..S PSGBST=PSGBCSCH+PSGBCFR,PSGBST=(PSGBST\86400)_","_(PSGBST#86400)
         ..I $P(PSGBST,",",2)<3600 S $P(PSGBST,",",2)=3600
         ..;If next day
         ..I $P(PSGBST,",",2)<3600 S %H=$S(+PSGBST=+PSGBCSHH:+PSGBST,1:PSGBST-1)
          _",86400"
         ..S %H=PSGBST D YMD^%DTC S PSGBST=X_(+$E(%,1,5))
         ..I PSGBST<LI S PSGBST="" Q
         ..;If the date/time is > than the First admin
         ..I AT,($P(PSGBST,".",1)>PSGBCLID) D
         ...S PSGBSAT=$P(PSGBST,".",2) I $L(PSGBSAT)=1 S PSGBSAT=PSGBSAT*10
         ...S PSGBSATN=$P(AT,"-",1)  ;First admin TIME
         ...I PSGBSAT>PSGBSATN S PSGBST=$P(PSGBST,".",1)_"."_PSGBSATN
         ...Q
         ..Q
         .;Future Date?
         .I (PSGBST)&((PSGBST<LI)!(($P(PSGBCADM,"^",1)+.0001)>PSGBST)) D
         ..S INFO=($S(($P(PSGBCADM,"^",1)+.0001>PSGBST):$P(PSGBCADM,"^",1)+.0001
          ,1:$G(LI)))_U_($G(PSGFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGPDRG))
          _U_($G(PSGS0Y))
         ..S PSGBST=$$ENQ^PSJORP2(PSGP,INFO)
         ..I PSGBST<LI S PSGBST="" Q
         ..Q
         .;No Sched time
         .I PSGBCLDT,PSGBCFR,'PSGBCSCH D  Q
         ..;Add Freq
         ..S PSGBST=PSGBCLDT+PSGBCFR,PSGBST=(PSGBST\86400)_","_(PSGBST#86400)
         ..I $P(PSGBST,",",2)<3600 S $P(PSGBST,",",2)=3600
         ..I $P(PSGBST,",",2)#3600 S PSGBTT=$P(($P(PSGBST,",",2)/3600)+1,".",1)*
          3600,$P(PSGBST,",",2)=PSGBTT
         ..;If next day
         ..I $P(PSGBST,",",2)<3600 S %H=$S(+PSGBST=+PSGBCLHH:+PSGBST,1:PSGBST-1)
          _",86400"
         ..S %H=PSGBST D YMD^%DTC S PSGBST=X_(+$E(%,1,3))
         ..I PSGBST<LI S PSGBST="" Q
         ..Q
         ;BHW;PSJ*5*179;END
         I $G(PSJSYSW0)=""!($P(PSJSYSW0,U,5)=2) Q LI
         S:SCH["PRN" AT=""
         N INT,PSG S:(SCH'["PRN"&(SCH'?1"Q".N1"H")&(LI'=OSD)&('AT)&($G(PSGST)'="
          O")) AT=$E(OSD,9,10) S OSD=$E(OSD,1,10)
         S INT=$S(SCH="QD":24,SCH="QOD":48,SCH="QH":1,SCH?1"Q".N1"D":(+$P(SCH,"Q
          ",2)*24),SCH?1"Q".N1"H":+$P(SCH,"Q",2),LI=OSD:24,1:24)
         S:INT=24 OSD=$$FMADD^XLFDT(LI,0,-INT,0,0)
         I 'AT,INT>23 S:$P(PSJSYSW0,U,5)!($E(LI,11,12)>30) AT=$E($$FMADD^XLFDT(L
          I,0,1,0,0),9,10) S:AT="00" AT=24 S:'AT AT=$E(LI,9,10)
         I SCH?1"Q".N1"H",'AT S ND=OSD,PSG(+ND)="" S:(INT>24)&('$G(PSJREN)) INT=
          24 S DAYS=INT\24,HRS=(-INT\24*24+INT) F  S ND=$$FMADD^XLFDT(ND,DAYS,HR
          S),PSG(+ND)="" Q:ND>LI
         Q:INT=24&'$L(AT,"-") $E(LI,1,8)_AT
         I '$O(PSG(LI)) S X=$S(OSD>1:OSD,LI>1:LI,1:$$DATE^PSJUTL2) D
         .F  S ND=X D  Q:ND>LI  S:(INT>24)&('$G(PSJREN)) INT=24 S DAYS=INT\24,HR
          S=(-INT\24*24+INT) S X=$$FMADD^XLFDT($S($P(ND,".",2)=24:$P(ND,".")_".2
          3",1:ND),DAYS,HRS) S:$P(X,".")'>$P(ND,".") X=$$FMADD^XLFDT(X,1,0,0,0)
         ..F Y=1:1 S AT1=$P(AT,"-",Y) Q:'AT1  S ND=ND\1_"."_AT1,PSG(+ND)=""
         Q:$P(PSJSYSW0,U,5) $O(PSG(LI))
         S INT="" F ND=0:0 S ND=$O(PSG(ND)) S X=$$FMDIFF^XLFDT(LI,ND,2) S:X<0 X=
          -X Q:INT&(X'<INT)  S INT=+X,OND=ND Q:INT=0
         Q $S($G(OND):OND,1:LI)  ;Use login time if OND is null PSJ*5*193

*****   INDEX OF PSGNE3   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
>> %            SF+2,SF+4,ENWALL+2,ENSD+73,ENSD+96
>> %H           ENSD+32,ENSD+33,ENSD+72*,ENSD+73*,ENSD+95*,ENSD+96*
>> %T           ENSD+32,ENSD+33
   A            SF+11~,SF+12*,SF+13*,SF+14*,SF+15*,SF+17*
   AA           SF+11~,SF+17*
>> APPT         ENSD+2
   AT           ENSD~,ENSD+31,ENSD+37,ENSD+42,ENSD+43,ENSD+61,ENSD+64,ENSD+76
                ENSD+78,ENSD+101*,ENSD+102*,ENSD+105*,ENSD+106,ENSD+107
                ENSD+110
>> AT1          ENSD+110*
   B            SF+11~,SF+17*
>> CLOZPAT      SF+24,SF+25,SF+26
   DA           ENOR+1,ENOR+2,ENSET0+1~*
>> DAYS         ENSD+106*,ENSD+109*
   DFN          ENSET0~,ENSET0+1,ENSET0+2,ENWALL~,ENWALL+3,ENWALL+6,ENSD+15
                ENSD+19,ENSD+20,ENSD+27,ENSD+28
   DIK          ENSET0+1~*
   DIK(1        ENSET0+1*
   ET           STOP+1!
   F            STOP+1!
   FD           ENWALL~,ENWALL+6
   FT           STOP+1!
>> HRS          ENSD+106*,ENSD+109*
>> INFO         ENSD+84*,ENSD+85
   INT          ENSD+102~,ENSD+103*,ENSD+104,ENSD+105,ENSD+106*,ENSD+107
                ENSD+109*,ENSD+112*
   LI           ENSD~,ENSD+4,ENSD+5,ENSD+6,ENSD+7,ENSD+8*,ENSD+9,ENSD+23
                ENSD+74,ENSD+83,ENSD+84,ENSD+86,ENSD+97,ENSD+100,ENSD+102
                ENSD+103,ENSD+104,ENSD+105,ENSD+106,ENSD+107,ENSD+108,ENSD+109
                ENSD+111,ENSD+112,ENSD+113
   LT           STOP+1!
>> ND           ENSD+106*,ENSD+109*,ENSD+110*,ENSD+112*
   NT           STOP+1!
   NWALL        ENWALL+1~,ENWALL+5*,ENWALL+6
>> OND          ENSD+112*,ENSD+113
   OSD          ENSD~,ENSD+7,ENSD+9*,ENSD+102*,ENSD+103,ENSD+104*,ENSD+106
                ENSD+108
   OSDLI        ENSD+3~,ENSD+7*,ENSD+9!
>> PSBSTR       OUT+2
   PSG          ENSD+102~
   PSG(         ENSD+106*,ENSD+108,ENSD+110*,ENSD+111,ENSD+112
   PSGBCADM     ENSD+11~,ENSD+13*,ENSD+20*,ENSD+22,ENSD+24,ENSD+38,ENSD+83
                ENSD+84
   PSGBCFR      ENSD+11~,ENSD+13*,ENSD+26*,ENSD+27*,ENSD+28*,ENSD+30*,ENSD+31
                ENSD+64,ENSD+67,ENSD+69,ENSD+89,ENSD+91
   PSGBCLA      ENSD+11~,ENSD+24*,ENSD+25
   PSGBCLDT     ENSD+11~,ENSD+24*,ENSD+33*,ENSD+89,ENSD+91
   PSGBCLHH     ENSD+11~,ENSD+33*,ENSD+95
   PSGBCLID     ENSD+12~,ENSD+23*,ENSD+40,ENSD+61,ENSD+64,ENSD+76
   PSGBCLIT     ENSD+11~,ENSD+23*,ENSD+40
>> PSGBCND      ENSD+16*,ENSD+17*,ENSD+20
>> PSGBCORD     ENSD+14*,ENSD+15*,ENSD+16,ENSD+17,ENSD+18*,ENSD+19,ENSD+27
                ENSD+28
>> PSGBCOT      ENSD+16*,ENSD+17*,ENSD+20
>> PSGBCPO      ENSD+16*,ENSD+17*,ENSD+20
>> PSGBCPRV     ENSD+19*,ENSD+20*
   PSGBCSCD     ENSD+12~,ENSD+24*,ENSD+40,ENSD+47,ENSD+51,ENSD+64,ENSD+65
>> PSGBCSCH     ENSD+24*,ENSD+32*,ENSD+35,ENSD+69,ENSD+89
   PSGBCSHH     ENSD+11~,ENSD+32*,ENSD+72
   PSGBCTDA     ENSD+12~,ENSD+51*,ENSD+53
   PSGBCTDD     ENSD+12~,ENSD+48*,ENSD+51,ENSD+60
   PSGBCTDY     ENSD+11~,ENSD+48*,ENSD+51,ENSD+57*,ENSD+59
   PSGBCTMP     ENSD+49!*
   PSGBCTMP(    ENSD+49*,ENSD+53,ENSD+54,ENSD+57,ENSD+58
   PSGBDNXT     ENSD+12~,ENSD+53*,ENSD+54*,ENSD+55*,ENSD+58*,ENSD+59
   PSGBNAT      ENSD+11~,ENSD+41*,ENSD+43*,ENSD+47,ENSD+61,ENSD+64,ENSD+65
   PSGBSAT      ENSD+11~,ENSD+38*,ENSD+39*,ENSD+40*,ENSD+42*,ENSD+43,ENSD+77*
                ENSD+79
   PSGBSATN     ENSD+11~,ENSD+43*,ENSD+78*,ENSD+79
   PSGBST       ENSD+11~,ENSD+13*,ENSD+22,ENSD+37,ENSD+45,ENSD+61*,ENSD+64*
                ENSD+65*,ENSD+69*,ENSD+70*,ENSD+72,ENSD+73*,ENSD+74*,ENSD+76
                ENSD+77,ENSD+79*,ENSD+83,ENSD+84,ENSD+85*,ENSD+86*,ENSD+91*
                ENSD+92*,ENSD+93*,ENSD+95,ENSD+96*,ENSD+97*
   PSGBTT       ENSD+11~,ENSD+93*
   PSGDAYC      ENSD+12~,ENSD+53*,ENSD+54
   PSGDL        OUT+4!,DFD+2*
   PSGDT        NOW+2*,ENFD~,SF,SF+3,ENSD+2
>> PSGFD        SF+20,ENSD+84
>> PSGFDX       OUT+2
   PSGNE3       STOP+1!
>> PSGNEDFD     SF+19,DFD+1,DFD+2,DFD+3,ENOR+2
>> PSGNEFD      SF+3*,SF+5*,SF+7*,SF+20,SF+21*,SF+25*,SF+26*,SF+27,SF+29*
                OUT+2*,OUT+3,DFD+3*
>> PSGNEFDO     OUT+3*
>> PSGNESD      NOW+2*,STOP+1,SF+3,SF+4,SF+5,SF+7,SF+8,SF+21,SF+22,SF+25,OUT+2*
                DFD+1,ENOR+2
>> PSGNESDO     STOP+1*
   PSGNEW       SF+3*,SF+4*,SF+27,SF+28,SF+29,OUT+4!,DFD+3
   PSGODF       STOP+1,OUT+3,ENOR+1!
>> PSGOEA       SF+2,SF+4
   PSGOES       STOP+1,OUT+3,ENOR+1!
>> PSGORD       SF+12,SF+13,SF+14,SF+15,SF+20,SF+28,ENSD+2,ENSD+14
>> PSGP         SF,SF+2,SF+3,SF+5,SF+7,SF+14,SF+15,SF+20,ENSD+85
>> PSGPDNX      OUT+2
>> PSGPDRG      ENSD+84
>> PSGRDTX      SF+28
>> PSGS0XT      SF+19
>> PSGS0Y       NOW+2,SF+19,ENSD+84
>> PSGSCH       NOW+2,SF+7,ENSD+84
>> PSGSDX       OUT+2
>> PSGST        NOW+1*,NOW+2,SF+5,SF+7,ENSD+84,ENSD+102
>> PSJORD       ENSD+14
>> PSJREN       ENSD+106,ENSD+109
>> PSJSYSW0     SF+1*,SF+2,SF+3,SF+5,SF+7,SF+8,SF+22,SF+27,DFD+1,DFD+3,ENWALL+4
                ENWALL+5,ENSD+100,ENSD+105,ENSD+111
   SCH          ENSD~,ENSD+45,ENSD+54,ENSD+55,ENSD+101,ENSD+102,ENSD+103
                ENSD+106
   SD           ENWALL~,ENWALL+3,ENWALL+5
   TT           STOP+1!
   U            SF,SF+3,SF+27,SF+28,ENWALL+4,ENWALL+5,ENWALL+6,ENSD+20,ENSD+24
                ENSD+27,ENSD+28,ENSD+84,ENSD+100,ENSD+105,ENSD+111
   WALL         ENWALL+1~,ENWALL+3*
   X            SF+4,SF+22*,SF+25~,SF+26,DFD+1*,DFD+3,ENOR+1*,ENOR+2*,ENWALL+3
                ENWALL+5,ENSD+3~,ENSD+4*,ENSD+5*,ENSD+6*,ENSD+8,ENSD+32*
                ENSD+33*,ENSD+47,ENSD+48,ENSD+51*,ENSD+53*,ENSD+54*,ENSD+61
                ENSD+64,ENSD+73,ENSD+96,ENSD+108*,ENSD+109*,ENSD+112*
   X1           PSGNE3+7~,ENFD+1~,SF+4*,SF+8*,SF+25~*,DFD+1*,ENWALL+1~
                ENWALL+3*,ENWALL+4*,ENSD+47*,ENSD+60*,ENSD+64*
   X2           PSGNE3+7~,ENFD+1~,SF+4*,SF+8*,SF+17*,SF+25~*,DFD+1*,ENWALL+1~
                ENWALL+3*,ENWALL+4*,ENSD+47*,ENSD+59*,ENSD+64*
   X3           SF+25~*,ENWALL+1~,ENWALL+2*,ENWALL+4
   X3DMIN       ENFD+1~,SF+20*,SF+21*
>> XD           ENSD+2*
   Y            PSGNE3+7~,ENFD+1~,ENSD+110*

Global Variables  ( * Changed  ! Killed)
   ^PS(51.1            SF+7
   ^PS(53.1            SF,SF+13,ENOR+1,ENOR+2*
   ^PS(53.46           SF+17
   ^PS(55              SF*,SF+3,SF+14,SF+15,ENSET0+1*,ENSET0+2*,ENWALL+3
                       ENWALL+6*,ENSD+15,ENSD+20,ENSD+27,ENSD+28

Naked Globals
   NONE

Cache Objects
   NONE

Marked Items
   NONE

Label References
   $$ENSD       NOW+2
   DFD          SF+19
   ENWALL       SF+2
   OUT          SF+5,SF+7,SF+20
   PSGNE3       ENOR+2
   SF           STOP+1

External References
   C^%DTC              SF+4,SF+18,SF+25,DFD+1,ENWALL+3,ENWALL+4,ENSD+47,ENSD+60
                       ENSD+64
   DW^%DTC             ENSD+48,ENSD+51
   H^%DTC              ENSD+32,ENSD+33
   NOW^%DTC            ENWALL+2,ENSD+47
   YMD^%DTC            ENSD+73,ENSD+96
   EN^DIK              ENSET0+1
   $$EN^PSBAPIPM       ENSD+20
   EN1^PSGDL           DFD+2
   $$ENDD^PSGMI        STOP+1,OUT+3
   $$ENOSD^PSJDCU      SF+5,SF+7
   $$DURMIN^PSJLIVMD   SF+21
   $$GETDUR^PSJLIVMD   SF+20
   $$ENQ^PSJORP2       ENSD+85
   $$DATE^PSJUTL2      NOW+2,ENSD+108
   $$DATE2^PSJUTL2     ENSD+2
   $$FMADD^XLFDT       SF+21,ENSD+8,ENSD+104,ENSD+105,ENSD+106,ENSD+109
   $$FMDIFF^XLFDT      ENSD+2,ENSD+112

*****   END   *****


PSGOD    * *  86 Lines,  5301 Bytes, Checksum: B25427452
                                                  Jul 01, 2016@13:24:55 page 3
              1010 bytes in comments
PSGOD    ;BIR/CML3-CREATES NEW ORDER FROM OLD ONE ;22 SEP 97 / 2:56 PM 
         ;;5.0;INPATIENT MEDICATIONS;**67,58,111,133,181,286,281,327**;16 DEC 97
          ;Build 10
         ;
         ; Reference to ^PS(55 is supported by DBIA 2191.
         ;
         ;*286 - Do not allow copied Unit Dose orders for outpatients
         D INP^VADPT I 'VAIN(4) W !,"You cannot copy Unit Dose orders for this p
          atient!" H 2 Q
         I $P($G(^PS(55,PSGP,5,+PSJORD,0)),"^",22) D  Q
         .W !,"This order is marked 'Not To Be Given' and can't be copied!" H 2
         F  W !!,"Do you want to copy this order" S %=2 D YN^DICN Q:%  D CH
         G:%'=1 DONE
         ;
         W !!,"...copying..." N OLDON
         K PSGORQF
         N PSGPDRG,Q
         S PSGOEPR=$P($G(^PS(55,PSGP,5.1)),"^",2),OLDON=PSGORD,Q=""
         ;K PSGODN S F=$S((PSGORD["N")!(PSGORD["P"):"^PS(53.1,"_+PSGORD_",",1:"^
          PS(55,"_PSGP_",5,"_+PSGORD_",") F N=0,.2,2,6 S PSGODN(N)=$G(@(F_N_")")
          )
         K PSGODN S F=$S(PSGORD["P":"^PS(53.1,"_+PSGORD_",",1:"^PS(55,"_PSGP_",5
          ,"_+PSGORD_",") F N=0,.2,2,6 S PSGODN(N)=$G(@(F_N_")"))
         S PSGPR=$P(PSGODN(0),"^",2),PSGMR=$P(PSGODN(0),"^",3),PSGSM=$P(PSGODN(0
          ),"^",5),PSGHSM=$P(PSGODN(0),"^",6),PSGST=$P(PSGODN(0),"^",7)
         S PSGPDRG=+PSGODN(.2),PSGDO=$P(PSGODN(.2),"^",2)
         S PSGSI=PSGODN(6)
         ; The naked reference below refers to the full reference inside indirec
          tion to ^PS(55,PSGP,5,+PSGORD, or ^PS(55,PSGP,"IV",+PSGORD, or ^PS(53.
          1,+PSGORD
         S PSGODN(3)=0 F Q=0:0 S Q=$O(@(F_"3,"_Q_")")) Q:'Q  I $D(^(Q,0)) S PSGO
          DN(3,Q)=^(0),PSGODN(3)=PSGODN(3)+1 S ^PS(53.45,PSJSYSP,1,Q,0)=^(0)
         ;S:PSGODN(12)>0 ^PS(53.45,PSJSYSP,4,0)="^53.4504" S:PSGODN(3)>0 ^PS(53.
          45,PSJSYSP,1,0)="^53.4501"
         S:PSGODN(3)>0 ^PS(53.45,PSJSYSP,1,0)="^53.4501"
         ; The naked reference below refers to the full reference inside indirec
          tion to ^PS(55,PSGP,5,+PSGORD, or ^PS(55,PSGP,"IV",+PSGORD, or ^PS(53.
          1,+PSGORD  
         S (PSGODN(1),Q)=0 F  S Q=$O(@(F_"1,"_Q_")")) Q:'Q  S ND=$G(^(Q,0)) I ND
          ,'$P(ND,"^",3) S PSGODN(1)=PSGODN(1)+1,PSGODN(1,PSGODN(1))=$P(ND,"^",1
          ,2) S ^PS(53.45,PSJSYSP,2,PSGODN(1),0)=^(0)
         S PSGS0Y=$P(PSGODN(2),"^",5),PSGS0XT=$P(PSGODN(2),"^",6),PSGNESD="",PSG
          SCH=$P(PSGODN(2),U)
         S PSGODF=1,PSGNEDFD=$P($$GTNEDFD^PSGOE7("U",+PSGPDRG),U)_"^^"_PSGST_"^"
          _PSGSCH
         W "." D ^PSGNE3
         K PSGEFN,PSGOEEF,PSGOEE,PSGOEOS S PSGEFN="1:13" F X=1:1:13 S PSGEFN(X)=
          ""
         S PSGPDN=$$OINAME^PSJLMUTL(PSGPDRG),PSGOINST="",PSGSDN=$$ENDD^PSGMI(PSG
          NESD)_U_$$ENDTC^PSGMI(PSGNESD),PSGFDN=$$ENDD^PSGMI(PSGNEFD)_U_$$ENDTC^
          PSGMI(PSGNEFD)
         S PSGAT=PSGS0Y,PSGEBN=DUZ,PSGLIN=$$ENDD^PSGMI(PSGDT)_U_$$ENDTC^PSGMI(PS
          GDT),PSGEBN=$$ENNPN^PSGMI(DUZ),PSGSTAT=$S(PSGOEAV:"ACTIVE",1:"NON-VERI
          FIED")
         W "." D CHK^PSGOEV("^^"_PSGMR_"^^^^"_PSGST,PSGPDRG_U_PSGDO,PSGSCH_U_PSG
          NESD_"^^"_PSGNEFD)
         I $G(PSGSCH)]"" D
         .N X S X=PSGSCH N SWD,SDW,XABB,QX D ENOS^PSGS0 I $G(X)=""!$G(PSJNSS) S 
          CHK=1 K PSJNSS Q
         .I $G(PSGAT)="",$G(PSGS0Y) S PSGAT=PSGS0Y
         .I $G(PSGAT),($G(PSGS0Y)="") S PSGS0Y=PSGAT
         .I $G(PSGS0XT)="D",$G(PSGS0Y)="" S CHK=1 D  K PSJNSS
         ..W ! K DIR S DIR(0)="FOA",DIR("A")="   WARNING - Admin times are requi
          red for DAY OF WEEK schedules    " D ^DIR K DIR
         S PSGSD=PSGNESD,PSGFD=PSGNEFD
         K PSJACEPT S VALMBCK="Q" D:$D(Y) EN^VALM("PSJU LM ACCEPT")
         I $G(PSJACEPT)=1 D OC S:$D(PSGORQF) PSJACEPT=0 S:$G(PSJACEPT)=1 VALMBCK
          ="",PSJNOO=$$ENNOO^PSJUTL5("N")
         I '$G(PSJACEPT)!($G(PSJNOO)<0) W:'$G(PSJCOFLG) !!,"Order not copied." D
           PAUSE^VALM1:'$G(PSJCOFLG) G ORIG    ;PSJCOFLG set in PSODGAL1 for all
          ergies
         S PSGNESD=PSGSD,PSGNEFD=PSGFD
         K PSGOEE D ^PSGOETO S PSJORD=PSGORD I PSGOEAV D
         .I '$D(PSGOEE),+PSJSYSU=3 D EN^PSGPEN(PSGORD)
         .D SETOC^PSJNEWOC(PSGORD) ;RTC 178789 Store allergy if auto vf is on
         D GETUD^PSJLMGUD(PSGP,PSGORD),ENSFE^PSGOEE0(PSGP,PSGORD),^PSGOE1,EN^VAL
          M("PSJ LM UD ACTION")
         ;RTC 178789 - store allery if not verified the newly copied order
         I ($G(PSGORD)["P"),($P($G(^PS(53.1,+PSGORD,0)),U,9)="N"),($G(PSJOCFG)="
          COPY UD") D SETOC^PSJNEWOC(PSGORD)
         ;
         S PSGCANFL=0,(PSGORD,PSJORD)=OLDON W !!,"You are finished with the new 
          order.",!,"The following ACTION prompt is for the original order."
         K DIR S DIR(0)="E" D ^DIR K DIR
ORIG     ;Redisplay original order
         D GETUD^PSJLMGUD(PSGP,OLDON),INIT^PSJLMUDE(PSGP,OLDON)
DONE     ;
         K %,%H,%I,DA,F,N,PSGODN,PSGODF,PSGS0XT,PSGS0Y,PSGNESD,PSGTOL,PSGTOO,PSG
          UOW,X,Y,^PS(53.45,PSJSYSP,1),^PS(53.45,PSJSYSP,2)
         K PSGPR,PSGMR,PSGSM,PSGHSM,PSGST,PSGPDRG,PSGDO,PSGNEDFD,PSGSCH,PSGNEFD
         Q
         ;
CH       ;
         W !!?2,"Answer 'YES' to have a new, non-verified order created for this
           patient,",!,"using the information from this order.  (The START and S
          TOP dates will be",!,"recalculated.)  Enter 'NO' (or '^') to stop now.
          " Q
         ;
WH       ;
         W !!?2,"Answer 'YES' to take action on this new order.  Enter 'NO' (or 
          '^') to return",!,"to the original order now." Q
         ;
OC       ;Perform order checks
         NEW PSJDD,X,PSJALLGY
         ;*286 - Order checks on current dispense drugs
         F X=0:0 S X=$O(^PS(53.45,PSJSYSP,2,X)) Q:'X  D
         . S PSJDD=$G(^PS(53.45,PSJSYSP,2,X,0))
         . I +PSJDD S PSJALLGY(+PSJDD)=""
         ;S X=+$O(PSGODN(1,0)) Q:'X  S PSJDD=+$G(PSGODN(1,X)) Q:'PSJDD
         S PSJDD=+$O(PSJALLGY(0)) Q:'PSJDD
         D FULL^VALM1
         D ENDDC^PSGSICHK($G(PSGP),PSJDD) Q:$D(PSGORQF)
         D IN^PSJOCDS($G(PSGORD),"UD",PSJDD)
         ;/RBN Begin PSJ*5.0*327 modification
         N DFN,PSGDRG
         S PSGDRG=PSGOP
         S PSGDRG=PSJBLOOP
         I $D(^PSDRUG("ACLOZ",PSGDRG)) D CLOZ^PSJCLOZ(PSGP,PSGDRG)
         I $G(ANQX) S PSJACEPT=0
         ;/RBN End PSJ*5.0*327 modifications
         Q

*****   INDEX OF PSGOD   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   %            PSGOD+9*,PSGOD+10,DONE+1!
   %H           DONE+1!
   %I           DONE+1!
>> ANQX         OC+16
>> CHK          PSGOD+35*,PSGOD+38*
   DA           DONE+1!
   DFN          OC+12~
   DIR          PSGOD+39!,PSGOD+53!
   DIR("A"      PSGOD+39*
   DIR(0        PSGOD+39*,PSGOD+53*
   DUZ          PSGOD+32
   F            PSGOD+17*,PSGOD+22,PSGOD+26,DONE+1!
   N            PSGOD+17*,DONE+1!
>> ND           PSGOD+26*
   OLDON        PSGOD+12~,PSGOD+15*,PSGOD+52,ORIG+1
>> PSGAT        PSGOD+32*,PSGOD+36*,PSGOD+37
>> PSGCANFL     PSGOD+52*
   PSGDO        PSGOD+19*,PSGOD+33,DONE+2!
   PSGDRG       OC+12~,OC+13*,OC+14*,OC+15
>> PSGDT        PSGOD+32
>> PSGEBN       PSGOD+32*
   PSGEFN       PSGOD+30!*
   PSGEFN(      PSGOD+30*
>> PSGFD        PSGOD+40*,PSGOD+44
>> PSGFDN       PSGOD+31*
   PSGHSM       PSGOD+18*,DONE+2!
>> PSGLIN       PSGOD+32*
   PSGMR        PSGOD+18*,PSGOD+33,DONE+2!
   PSGNEDFD     PSGOD+28*,DONE+2!
   PSGNEFD      PSGOD+31,PSGOD+33,PSGOD+40,PSGOD+44*,DONE+2!
   PSGNESD      PSGOD+27*,PSGOD+31,PSGOD+33,PSGOD+40,PSGOD+44*,DONE+1!
   PSGODF       PSGOD+28*,DONE+1!
   PSGODN       PSGOD+17!,DONE+1!
   PSGODN(      PSGOD+17*,PSGOD+19
   PSGODN(0     PSGOD+18
   PSGODN(1     PSGOD+26*
   PSGODN(2     PSGOD+27
   PSGODN(3     PSGOD+22*,PSGOD+24
   PSGODN(6     PSGOD+20
>> PSGOEAV      PSGOD+32,PSGOD+45
   PSGOEE       PSGOD+30!,PSGOD+45!,PSGOD+46
   PSGOEEF      PSGOD+30!
   PSGOEOS      PSGOD+30!
>> PSGOEPR      PSGOD+15*
>> PSGOINST     PSGOD+31*
>> PSGOP        OC+13
>> PSGORD       PSGOD+15,PSGOD+17,PSGOD+45,PSGOD+46,PSGOD+47,PSGOD+48,PSGOD+50
                PSGOD+52*,OC+10
   PSGORQF      PSGOD+13!,PSGOD+42,OC+9
>> PSGP         PSGOD+7,PSGOD+15,PSGOD+17,PSGOD+48,ORIG+1,OC+9,OC+15
>> PSGPDN       PSGOD+31*
   PSGPDRG      PSGOD+14~,PSGOD+19*,PSGOD+28,PSGOD+31,PSGOD+33,DONE+2!
   PSGPR        PSGOD+18*,DONE+2!
   PSGS0XT      PSGOD+27*,PSGOD+38,DONE+1!
   PSGS0Y       PSGOD+27*,PSGOD+32,PSGOD+36,PSGOD+37*,PSGOD+38,DONE+1!
   PSGSCH       PSGOD+27*,PSGOD+28,PSGOD+33,PSGOD+34,PSGOD+35,DONE+2!
>> PSGSD        PSGOD+40*,PSGOD+44
>> PSGSDN       PSGOD+31*
>> PSGSI        PSGOD+20*
   PSGSM        PSGOD+18*,DONE+2!
   PSGST        PSGOD+18*,PSGOD+28,PSGOD+33,DONE+2!
>> PSGSTAT      PSGOD+32*
   PSGTOL       DONE+1!
   PSGTOO       DONE+1!
   PSGUOW       DONE+1!
   PSJACEPT     PSGOD+41!,PSGOD+42*,PSGOD+43,OC+16*
   PSJALLGY     OC+1~
   PSJALLGY(    OC+5*
   PSJALLGY(0   OC+7
>> PSJBLOOP     OC+14
>> PSJCOFLG     PSGOD+43
   PSJDD        OC+1~,OC+4*,OC+5,OC+7*,OC+9,OC+10
>> PSJNOO       PSGOD+42*,PSGOD+43
   PSJNSS       PSGOD+35!,PSGOD+38!
>> PSJOCFG      PSGOD+50
>> PSJORD       PSGOD+7,PSGOD+45*,PSGOD+52*
>> PSJSYSP      PSGOD+22,PSGOD+24,PSGOD+26,DONE+1,OC+3,OC+4
>> PSJSYSU      PSGOD+46
   Q            PSGOD+14~,PSGOD+15*,PSGOD+22*,PSGOD+26*
   QX           PSGOD+35~
   SDW          PSGOD+35~
   SWD          PSGOD+35~
   U            PSGOD+27,PSGOD+28,PSGOD+31,PSGOD+32,PSGOD+33,PSGOD+50
>> VAIN(4       PSGOD+6
>> VALMBCK      PSGOD+41*,PSGOD+42*
   X            PSGOD+30*,PSGOD+35~*,DONE+1!,OC+1~,OC+3*,OC+4
   XABB         PSGOD+35~
   Y            PSGOD+41,DONE+1!

Global Variables  ( * Changed  ! Killed)
   ^PS(53.1            PSGOD+50
   ^PS(53.45           PSGOD+22*,PSGOD+24*,PSGOD+26*,DONE+1!,OC+3,OC+4
   ^PS(55              PSGOD+7,PSGOD+15
   ^PSDRUG("ACLOZ"     OC+15

Naked Globals
   ^(           PSGOD+22,PSGOD+26
   ^(0          PSGOD+22,PSGOD+26

Cache Objects
   NONE

Marked Items
   NONE

Label References
   CH           PSGOD+9
   DONE         PSGOD+10
   OC           PSGOD+42
   ORIG         PSGOD+43

External References
   YN^DICN             PSGOD+9
   ^DIR                PSGOD+39,PSGOD+53
   $$ENDD^PSGMI        PSGOD+31,PSGOD+32
   $$ENDTC^PSGMI       PSGOD+31,PSGOD+32
   $$ENNPN^PSGMI       PSGOD+32
   ^PSGNE3             PSGOD+29
   ^PSGOE1             PSGOD+48
   $$GTNEDFD^PSGOE7    PSGOD+28
   ENSFE^PSGOEE0       PSGOD+48
   ^PSGOETO            PSGOD+45
   CHK^PSGOEV          PSGOD+33
   EN^PSGPEN           PSGOD+46
   ENOS^PSGS0          PSGOD+35
   ENDDC^PSGSICHK      OC+9
   CLOZ^PSJCLOZ        OC+15
   GETUD^PSJLMGUD      PSGOD+48,ORIG+1
   INIT^PSJLMUDE       ORIG+1
   $$OINAME^PSJLMUTL   PSGOD+31
   SETOC^PSJNEWOC      PSGOD+47,PSGOD+50
   IN^PSJOCDS          OC+10
   $$ENNOO^PSJUTL5     PSGOD+42
   INP^VADPT           PSGOD+6
   EN^VALM             PSGOD+41,PSGOD+48
   FULL^VALM1          OC+8
   PAUSE^VALM1         PSGOD+43

*****   END   *****


PSGOE41  * *  121 Lines,  6545 Bytes, Checksum: B37515595
                                                  Jul 01, 2016@13:24:55 page 4
              883 bytes in comments
PSGOE41  ;BIR/CML3-REGULAR ORDER ENTRY (CONT.) ;09 JAN 97 / 9:13 AM 
         ;;5.0;INPATIENT MEDICATIONS;**50,63,64,69,58,111,136,113,267,327**;16 D
          EC 97;Build 10
         ;
         ; Reference to ^DICN is supported by DBIA 10009.
         ; Reference to %DT is supported by DBIA 10003.
         ; Reference to %DTC is supported by DBIA 10000.
         ; Reference to ^PS(51.1 is supported by DBIA 2177.
         ;
39       ; admin times
         G:$P(PSGNEDFD,"^",3)="P"!($P(PSGNEDFD,"^",3)="OC") 8
         I $$ODD^PSGS0(PSGS0XT) G 8
         W !,"ADMIN TIMES: "_$S(PSGS0Y:PSGS0Y_"// ",1:"") R X:DTIME I X="^"!'$T 
          W:'$T $C(7) S PSGOROE1=1 G DONE
         I X="",PSGS0Y]"" S X=PSGS0Y
         I X="",$G(PSGS0XT)="D" I $L(PSGSCH,"@")=2,$P(PSGSCH,"@",2) S (PSGAT,PSG
          S0Y)=$P(PSGSCH,"@",2) G 8
         I X?1."?" D ENHLP^PSGOEM(53.1,39) G 39
         I X="@" D DEL G:%'=1 39 S (PSGFOK(39),PSGS0Y)="" G 39
         S PSGF2=39 I $E(X)="^" D FF G:Y>0 @Y G 39
         I (PSGS0XT="D")&('$G(X)!(X["@"&($P($G(X),"@",2)))) I ((",P,R,")'[(","_$
          G(PSGST)_",")) D  G 39
         . W $C(7),"  ??" S X="?" W !,"This is a 'DAY OF THE WEEK' schedule and 
          MUST have admin times." D ENHLP^PSGOEM(53.1,39)
         I $G(PSGS0XT)'="D",$G(PSGS0XT)'="P",$G(PSGS0XT)'="OC" D TIMES I '$D(X) 
          G 39
         I $G(PSGS0XT)="O",X="" S (PSGAT,PSGS0Y)=X,PSGFOK(39)="" G 8
         D ENCHK^PSGS0 I '$D(X) W $C(7),"  ??" G 39
         S (PSGAT,PSGS0Y)=X,PSGFOK(39)=""
         ;
8        ; special instructions
         S PSGSI=$$EDITSI^PSJBCMA5($G(PSGP),$G(PSGORD))
         S PSGF2=8 I $E(X)="^" D FF G:Y>0 @Y G 8
         I X="@",PSGSI="" W $C(7),"  ??" S X="?" D ENHLP^PSGOEM(53.1,8) G 8
         I X="@" D DEL G:%'=1 8 S (PSGFOK(8),PSGSI)="" G:'$G(PSGOE3) 10
         I X?1."?" D ENHLP^PSGOEM(53.1,8) G 8
         S PSGSI=$S((PSGSI>0&(PSGSI<3)):$G(^PS(53.45,+PSJSYSP,5,1,0))_" "_$G(^PS
          (53.45,+PSJSYSP,5,2,0)),PSGSI>2:"Instructions too long. See Order View
           or BCMA for full text",1:"")
         I PSGSI]"" S PSGSI=$$ENBCMA^PSJUTL("U"),PSGFOK(8)=""
         Q:$G(PSGOE3)
10       ; start date/time
         D ^PSGNE3
         S:'$D(PSGNESDO) PSGNESDO=$$ENDD^PSGMI(PSGNESD) S PSGSD=PSGNESDO
A10      W !,"START DATE/TIME: "_PSGSD_"// " R X:DTIME I X="^"!'$T W:'$T $C(7) S
           PSGOROE1=1 G DONE
         I X="",PSGNESD W "  "_PSGSD G O25
         I X="P" D ENPREV^PSGDL W:'$D(X) $C(7) G:'$D(X) A10 S PSGNESD=+X,PSGSD=$
          $ENDD^PSGMI(+X) W "  ",PSGSD G O25
         S PSGF2=10 I X="@"!(X?1."?") W:X="@" $C(7),"  (Required)" S:X="@" X="?"
           D ENHLP^PSGOEM(53.1,10)
         I $E(X)="^" D FF G:Y>0 @Y G A10
         NEW TMPX S TMPX=X,X1=PSGDT,X2=-7 D C^%DTC K %DT S %DT="ERTX",%DT(0)=X,X
          =TMPX D ^%DT K %DT I Y'>0 D ENHLP^PSGOEM(53.1,10) G A10
         S PSGNESD=+Y,PSGSD=$$ENDD^PSGMI(+Y),(PSGNEFD,PSGFD)=""
         ;
O25      ;
         S PSGFOK(10)="" I $P(PSGNEDFD,"^",3)="O" S PSGNEFD=$$ENOSD^PSJDCU(PSJSY
          SW0,PSGNESD,PSGP) I PSGNEFD]"" S PSGFD=$$ENDD^PSGMI(PSGNEFD)
         ;
25       ; stop date
         Q:$G(PSGOE3)
         I 'PSGNEFD D ENFD^PSGNE3(PSGDT) S PSGFD=PSGNEFDO
         ;/RBN-RJS Begin changes for emergency registration of clozapine patient
           Set end date to start date + 4 days at midnight.
         I $G(^TMP("CLOZFLG",DFN)) D
         .N X,X1,X2,X3 S X3=$P(PSGNESD,".",1)_".2359",X1=X3,X2=4 D C^%DTC S PSGN
          EFD=X,PSGFD=$$ENDD^PSGMI(PSGNEFD)
         .S PSGCFLG=0,PSGOLDED=PSGFD,PSGNEFDOLD=PSGNEFD
         I $D(CLOZPAT),'$G(^TMP("CLOZFLG",DFN)) D
         .N X,X1,X2
         .S X1=PSGNESD,X2=$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1
          :90) D C^%DTC S PSGNEFD=X,PSGFD=$$ENDD^PSGMI(PSGNEFD)
         .S PSGCFLG=0,PSGOLDED=PSGFD,PSGNEFDOLD=PSGNEFD
         ;/RBN-RJS End changes for emergency registration of clozapine patient
A25      W !,"STOP DATE/TIME: "_$S(PSGFD]"":PSGFD_"// ",1:"") R X:DTIME I X="^"!
          '$T W:'$T $C(7) S PSGOROE1=1 G DONE
         I X="",PSGNEFD W "   "_PSGFD S PSGFOK(25)=""  G W25
         S PSGF2=25 I $E(X)="^" D FF G:Y>0 @Y G A25
         I X="@"!(X?1."?") W:X="@" $C(7),"  (Required)" S:X="@" X="?" D ENHLP^PS
          GOEM(53.1,25)
         I X=+X,(X>0),(X'>2000000) G A25:'$$ENDL^PSGDL(PSGSCH,X) K PSGDLS S PSGD
          L=X W " ...dose limit..." D EN1^PSGDL
         K %DT S %DT="ERTX",%DT(0)=PSGNESD D ^%DT K %DT G:Y'>0 A25 S PSGNEFD=+Y,
          PSGFD=$$ENDD^PSGMI(+Y),PSGFOK(25)=""
         ;/RJS Begin changes for emergency registration of clozapine patient Set
           end date to start date + 4 days at midnight.
         I $D(CLOZPAT),'$G(^TMP("CLOZFLG",DFN)) D
         .N X1,X2
         .S X1=PSGNESD,X2=$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1
          :90)
         .I $P(PSGNEFD,".",1)-$P(PSGNESD,".",1)'=X2 S PSGCFLG=1,PSGFD=PSGOLDED,P
          SGNEFD=PSGNEFDOLD W !!,"*** STOP DATE/TIME NOT TO EXCEED "_X2_" DAYS! 
          ***",!
         G:$G(PSGFLG) A25
         ;.D C^%DTC S PSGNEFD=X,PSGFD=$$ENDD^PSGMI(PSGNEFD)
         I $G(^TMP("CLOZFLG",DFN)) D  G:X>4 A25
         .S X1=+Y,X2=PSGNESD D ^%DTC
         .Q:X'>4
         .I X>4 D
         ..W !!?13,"*** EMERGENCY SUPPLY NOT TO EXCEED 4 DAYS! ***",!
         ..N X,X1,X2,X3 S X3=$P(PSGNESD,".",1)_".2359",X1=X3,X2=4 D C^%DTC S PSG
          NEFD=X
         ..S PSGFD=$$ENDD^PSGMI(PSGNEFD)
         ;/RJS End changes for emergency registration of clozapine patient
W25      ;
         N Z
         D DOSE I $G(Z)]"",Z>PSGNEFD D  G A25
         . W !,"There must be an admin time that falls between the Start Date/Ti
          me"
         . W !,"and the Stop Date/Time."
         I PSGNEFD<PSGDT W $C(7),!!?13,"*** WARNING! THE STOP DATE ENTERED IS IN
           THE PAST! ***",!
         D EFDNEW^PSJUTL  ;Display Expected First Dose;BHW;PSJ*5*136
NEXT     ;
         G 1^PSGOE42
         ;
DONE     ;
         I PSGOROE1 K Y W $C(7),"  ...order not entered..."
         K F,F0,F1,PSGF2,F3,PSG,SDT,PSGCFLG Q
         ;
FF       ; up-arrow to another field
         D ENFF^PSGOEM I Y>0,Y'=39,Y'=8,Y'=10,Y'=25 S Y=Y_"^PSGOE4"_$S("^109^13^
          3^7^26^"[("^"_Y_"^"):"",1:2) S:$P(Y,U)=2 FB=PSGF2_"^PSGOE41"
         Q
         ;
DEL      ; delete entry
         W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W $C(7),"  <NOTH
          ING DELETED>"
         Q
TIMES       ;At least one admin time, not more than interval allows.
         I $G(PSGS0XT)'="O",X="" W !,"This order requires at least one administr
          ation time." K X Q  ;No times
         N H,I,MAX
         I PSGSCH]"" I $D(^PS(51.1,"AC","PSJ",PSGSCH)) S H=+$O(^PS(51.1,"AC","PS
          J",PSGSCH,0)) S I=$P($G(^PS(51.1,H,0)),"^",3)
         I $G(PSGST)="O",$L(X,"-")>1 W !,"This is a One Time Order - only one ad
          min time is permitted." K X Q
         I $G(PSGST)="O" Q  ;Done validating One Time
         I +$G(I)=0 Q  ;No frequency - can not check frequency related items
         S MAX=1440/I
         I MAX<1 D  Q
         . I $L(X,"-")'=1 W !,"This order requires one admin time." K X Q
         I MAX'<1,$L(X,"-")>MAX W !,"The number of admin times entered is greate
          r than indicated by the schedule." K X Q  ;Too many times
         I MAX'<1,$L(X,"-")<MAX W !,"The number of admin times entered is fewer 
          than indicated by the schedule."  ;Too few times
         Q
DOSE     ;Make certain at least one dose is given.
         Q:$G(PSGST)="OC"!($G(PSGST)="P")
         N INFO,X
         S Z="",INFO=($G(PSGNESD))_U_($G(PSGNEFD))_U_($G(PSGSCH))_U_($G(PSGST))_
          U_($G(PSGDRG))_U_($G(PSGS0Y))
         I '$L($G(PSGP)) N PSGP S PSGP=""
         S Z=$$ENQ^PSJORP2(PSGP,INFO)  ;Expected first dose.
         Q

*****   INDEX OF PSGOE41   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
>> %            39+7,8+4,DEL+1*
   %DT          A10+5!*,A25+5!*
   %DT(0        A10+5*,A25+5*
>> CLOZPAT      25+7,25+9,A25+7,A25+9
>> DFN          25+4,25+7,A25+7,A25+13
   DTIME        39+3,A10,A25
   F            DONE+2!
   F0           DONE+2!
   F1           DONE+2!
   F3           DONE+2!
>> FB           FF+1*
   H            TIMES+2~,TIMES+3*
   I            TIMES+2~,TIMES+3*,TIMES+6,TIMES+7
   INFO         DOSE+2~,DOSE+3*,DOSE+5
   MAX          TIMES+2~,TIMES+7*,TIMES+8,TIMES+10,TIMES+11
   PSG          DONE+2!
>> PSGAT        39+5*,39+12*,39+14*
   PSGCFLG      25+6*,25+10*,A25+10*,DONE+2!
>> PSGDL        A25+4*
   PSGDLS       A25+4!
>> PSGDRG       DOSE+3
>> PSGDT        A10+5,25+2,W25+5
   PSGF2        39+8*,8+2*,A10+3*,A25+2*,DONE+2!,FF+1
>> PSGFD        A10+6*,O25+1*,25+2*,25+5*,25+6,25+9*,25+10,A25,A25+1,A25+5*
                A25+10*,A25+19*
>> PSGFLG       A25+11
>> PSGFOK(10    O25+1*
>> PSGFOK(25    A25+1*,A25+5*
>> PSGFOK(39    39+7*,39+12*,39+14*
>> PSGFOK(8     8+4*,8+7*
>> PSGNEDFD     39+1,O25+1
>> PSGNEFD      A10+6*,O25+1*,25+2,25+5*,25+6,25+9*,25+10,A25+1,A25+5*,A25+10*
                A25+18*,A25+19,W25+2,W25+5,DOSE+3
>> PSGNEFDO     25+2
>> PSGNEFDOLD   25+6*,25+10*,A25+10
>> PSGNESD      10+2,A10+1,A10+2*,A10+6*,O25+1,25+5,25+9,A25+5,A25+9,A25+10
                A25+14,A25+18,DOSE+3
>> PSGNESDO     10+2*
>> PSGOE3       8+4,8+8,25+1
>> PSGOLDED     25+6*,25+10*,A25+10
>> PSGORD       8+1
>> PSGOROE1     39+3*,A10*,A25*,DONE+1
   PSGP         8+1,O25+1,DOSE+4~*,DOSE+5
>> PSGS0XT      39+2,39+5,39+9,39+11,39+12,TIMES+1
>> PSGS0Y       39+3,39+4,39+5*,39+7*,39+12*,39+14*,DOSE+3
>> PSGSCH       39+5,A25+4,TIMES+3,DOSE+3
>> PSGSD        10+2*,A10,A10+1,A10+2*,A10+6*
>> PSGSI        8+1*,8+3,8+4*,8+6*,8+7*
>> PSGST        39+9,TIMES+4,TIMES+5,DOSE+1,DOSE+3
>> PSJSYSP      8+6
>> PSJSYSW0     O25+1
   SDT          DONE+2!
   TMPX         A10+5~*
   U            FF+1,DOSE+3
   X            39+3*,39+4*,39+5,39+6,39+7,39+8,39+9,39+10*,39+11,39+12,39+13
                39+14,8+2,8+3*,8+4,8+5,A10*,A10+1,A10+2,A10+3*,A10+4,A10+5*
                25+5~,25+8~,25+9,A25*,A25+1,A25+2,A25+3*,A25+4,A25+13,A25+15
                A25+16,A25+18~,TIMES+1!,TIMES+4!,TIMES+9!,TIMES+10!
                TIMES+11,DOSE+2~
   X1           A10+5*,25+5~*,25+8~,25+9*,A25+8~,A25+9*,A25+14*,A25+18~*
   X2           A10+5*,25+5~*,25+8~,25+9*,A25+8~,A25+9*,A25+10,A25+14*,A25+18~*
   X3           25+5~*,A25+18~*
   Y            39+8,8+2,A10+4,A10+5,A10+6,A25+2,A25+5,A25+14,DONE+1!,FF+1*
   Z            W25+1~,W25+2,DOSE+3*,DOSE+5*

Global Variables  ( * Changed  ! Killed)
   ^PS(51.1            TIMES+3
   ^PS(53.45           8+6
   ^TMP("CLOZFLG"      25+4,25+7,A25+7,A25+13

Naked Globals
   NONE

Cache Objects
   NONE

Marked Items
   NONE

Label References
   8            39+1,39+2,39+5,39+12,8+2,8+3,8+4,8+5
   10           8+4
   39           39+6,39+7,39+8,39+9,39+11,39+13
   @(           39+8,8+2,A10+4,A25+2
   A10          A10+2,A10+4,A10+5
   A25          A25+2,A25+4,A25+5,A25+11,A25+13,W25+2
   DEL          39+7,8+4
   DONE         39+3,A10,A25
   DOSE         W25+2
   FF           39+8,8+2,A10+4,A25+2
   O25          A10+1,A10+2
   TIMES        39+11
   W25          A25+1

External References
   ^%DT                A10+5,A25+5
   ^%DTC               A25+14
   C^%DTC              A10+5,25+5,25+9,A25+18
   YN^DICN             DEL+1
   $$ENDL^PSGDL        A25+4
   EN1^PSGDL           A25+4
   ENPREV^PSGDL        A10+2
   $$ENDD^PSGMI        10+2,A10+2,A10+6,O25+1,25+5,25+9,A25+5,A25+19
   ^PSGNE3             10+1
   ENFD^PSGNE3         25+2
   1^PSGOE42           NEXT+1
   ENFF^PSGOEM         FF+1
   ENHLP^PSGOEM        39+6,39+10,8+3,8+5,A10+3,A10+5,A25+3
   $$ODD^PSGS0         39+2
   ENCHK^PSGS0         39+13
   $$EDITSI^PSJBCMA5   8+1
   $$ENOSD^PSJDCU      O25+1
   $$ENQ^PSJORP2       DOSE+5
   $$ENBCMA^PSJUTL     8+7
   EFDNEW^PSJUTL       W25+6

*****   END   *****


PSGOE42  * *  65 Lines,  3240 Bytes, Checksum: B12591176
                                                  Jul 01, 2016@13:24:55 page 5
              206 bytes in comments
PSGOE42  ;BIR/CML3-REGULAR ORDER ENTRY (CONT.) ;09 JAN 97 / 9:25 AM
         ;;5.0;INPATIENT MEDICATIONS ;**327**;16 DEC 97;Build 10
         ;
         ;
1        ; provider
         I '+$G(PSJSYSU) S PSTMPI=PSGPR,PSTMPN=PSGPRN G A1
         I $S(+PSJSYSU=3:0,1:$P(PSJSYSU,";",2)) G:$P(PSJSYSW0,"^",24) 5 G DONE
         S PSTMPI=PSGPR,PSTMPN=PSGPRN
         ;;A1 W !,"PROVIDER: ",$S(PSGPR:PSGPRN_"// ",1:"") R X:DTIME I X="^"!'$T
           W:'$T $C(7) S PSGOROE1=1 G DONE
A1       W !,"PROVIDER: ",$S(PSGPR:PSGPRN_"// ",1:"") R X:DTIME I X="^" W $C(7) 
          S PSGOROE1=1 G DONE
         I $S(X="":'PSGPR,1:X="@") W $C(7),"  (Required)" S X="?",PSGF2=1 D ENHL
          P^PSGOEM(53.1,1) G 1
         I X="",PSGPR S X=PSGPRN I PSGPR'=PSGPRN,$D(^VA(200,PSGPR,"PS")) W "    
          "_$P(^("PS"),"^",2)_"    "_$P(^("PS"),"^",3) S PSGFOK(1)="" G A2
         S PSGF2=1 I X?1."?" D ENHLP^PSGOEM(53.1,1)
         I $E(X)="^" D FF G:Y>0 @Y G 1
         K DIC S DIC="^VA(200,",DIC(0)="EMQZ",DIC("S")="I $D(^(""PS"")),^(""PS""
          ),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)>DT)" D ^DIC K DI
          C I Y'>0 G 1
         S PSGPR=+Y,PSGPRN=$P(Y(0,0),"^"),PSGFOK(1)=""
A2       ;; START NCC T4 MODS >> 327*RJS
         I '$G(PSGDRG) S PSGDRG=$O(^PSDRUG("ASP",PSGPDRG,0)) I PSGDRG,'$O(^(PSGD
          RG)) Q
         I $D(^PSDRUG("ACLOZ",PSGDRG)) D
         .S ANQX=0 D PROVCHK^PSJCLOZ(PSGPR) ;(PSGP,PSGDRG)
         .I ANQX=0 K PSTMPN,PSTMPI
         I $G(ANQX) S PSGPR=PSTMPI,PSGPRN=PSTMPN  W ! K ANQX G A1
         ;; END NCC T4 MODS << 327*RJS
5        ; self med
         I '$P(PSJSYSW0,"^",24) G DONE
A5       W !,"SELF MED: " W:PSGSM]"" $P("NO^YES","^",PSGSM+1),"// " R X:DTIME I 
          X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
         I "01"[X,$L(X)<2 S:PSGSM=""&(X]"") PSGSM=X W:PSGSM]"" "  (",$P("NO^YES"
          ,"^",PSGSM+1),")" G DONE
         I X="@" W:PSGSM="" $C(7),"  ??" G:PSGSM="" A5 D DEL G:%'=1 A5 S (PSGSM,
          PSGHSM)="" G DONE
         S PSGF2=5 I X?1"^".E D FF G:Y>0 @Y G A5
         I X?1."?" S PSGF2=5 D ENHLP^PSGOEM(53.1,5) G A5
         D YN I  S PSGSM=$E(X)="Y",PSGFOK(5)="" G 6:PSGSM,DONE
         W $C(7) D ENHLP^PSGOEM(53.1,5) G A5
         ;
6        ; hospital supplied self med
         W !,"HOSPITAL SUPPLIED SELF MED: " W:PSGHSM]"" $P("NO^YES","^",PSGHSM+1
          ),"// " R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
         I "01"[X,$L(X)<2 S:PSGHSM=""&(X]"") PSGHSM=X W:PSGHSM]"" "  (",$P("NO^Y
          ES","^",PSGHSM+1),")" G DONE
         I X="@" W:PSGHSM="" $C(7),"  ??" G:PSGHSM="" 6 D DEL G:%'=1 6 S PSGHSM=
          "" G DONE
         S PSGF2=6 I X?1"^".E D FF G:Y>0 @Y G 6
         I X?1."?" D ENHLP^PSGOEM(53.1,6) G 6
         D YN I  S PSGHSM=$E(X)="Y" G DONE
         W $C(7) S PSGF2=6 D ENHLP^PSGOEM(53.1,6) G 6
         Q
         ;
DONE     ;
         K F,F0,F1,PSGF2,F3,PSG,SDT Q
         ;
FF       ; up-arrow to another field
         D ENFF^PSGOEM I Y>0,Y'=1,Y'=5 S Y=Y_"^PSGOE4"_$S("^109^13^3^7^26^"[("^"
          _Y_"^"):"",1:1)
         Q
         ;
DEL      ; delete entry
         W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W $C(7),"  <NOTH
          ING DELETED>"
         Q
         ;
YN       ; yes/no as a set of codes
         I X'?.U F Y=1:1:$L(X) I $E(X,Y)?1L S X=$E(X,1,Y-1)_$C($A(X,Y)-32)_$E(X,
          Y+1,$L(X))
         F Y="NO","YES" I $P(Y,X)="" W $P(Y,X,2) Q
         Q
         ;
2        ; dispense drug multiple
         I PSGDRG,'$D(^PS(53.45,PSJSYSP,2)) S ^(2,0)="^53.4502P^1^1",^(1,0)=PSGD
          RG_"^"_PSGUD
         K DA,DR S DIE="^PS(53.45,",DA=PSJSYSP,DR=2,DR(2,53.4502)=$S($G(PSGFOK(1
          3)):.02,1:".01;.02") D ^DIE
         I '$O(^PS(53.45,PSJSYSP,2,0)) W $C(7),!!,"WARNING: This order must have
           at least one dispense drug before pharmacy can",!?9,"verify it!"
         I $G(PSGFOK(13)) Q
         G @FB

*****   INDEX OF PSGOE42   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
>> %            A5+2,6+3,DEL+1*
   ANQX         A2+3*,A2+4,A2+5!
   DA           2+2!*
   DIC          A1+5!*
   DIC("S"      A1+5*
   DIC(0        A1+5*
>> DIE          2+2*
   DR           2+2!*
   DR(2         2+2*
   DTIME        A1,A5,6+1
   F            DONE+1!
   F0           DONE+1!
   F1           DONE+1!
   F3           DONE+1!
>> FB           2+5
   PSG          DONE+1!
>> PSGDRG       A2+1*,A2+2,2+1
   PSGF2        A1+1*,A1+3*,A5+3*,A5+4*,6+4*,6+7*,DONE+1!
>> PSGFOK(1     A1+2*,A1+6*
>> PSGFOK(13    2+2,2+4
>> PSGFOK(5     A5+5*
>> PSGHSM       A5+2*,6+1,6+2*,6+3*,6+6*
>> PSGOROE1     A1*,A5*,6+1*
>> PSGPDRG      A2+1
>> PSGPR        1+1,1+3,A1,A1+1,A1+2,A1+6*,A2+3,A2+5*
>> PSGPRN       1+1,1+3,A1,A1+2,A1+6*,A2+5*
>> PSGSM        A5,A5+1*,A5+2*,A5+5*
>> PSGUD        2+1
>> PSJSYSP      2+1,2+2,2+3
>> PSJSYSU      1+1,1+2
>> PSJSYSW0     1+2,5+1
   PSTMPI       1+1*,1+3*,A2+4!,A2+5
   PSTMPN       1+1*,1+3*,A2+4!,A2+5
   SDT          DONE+1!
>> X            A1*,A1+1*,A1+2*,A1+3,A1+4,A5*,A5+1,A5+2,A5+3,A5+4,A5+5,6+1*,6+2
                6+3,6+4,6+5,6+6,YN+1*,YN+2
>> Y            A1+4,A1+5,A1+6,A5+3,6+4,FF+1*,YN+1*,YN+2*
>> Y(0          A1+6

Global Variables  ( * Changed  ! Killed)
   ^PS(53.45           2+1,2+3
   ^PSDRUG("ACLOZ"     A2+2
   ^PSDRUG("ASP"       A2+1
   ^VA(200             A1+2

Naked Globals
   ^(           A2+1
   ^("PS"       A1+2
   ^(1          2+1*
   ^(2          2+1*

Cache Objects
   NONE

Marked Items
   NONE

Label References
   1            A1+1,A1+4,A1+5
   5            1+2
   6            A5+5,6+3,6+4,6+5,6+7
   @(           A1+4,A5+3,6+4,2+5
   A1           1+1,A2+5
   A2           A1+2
   A5           A5+2,A5+3,A5+4,A5+6
   DEL          A5+2,6+3
   DONE         1+2,A1,5+1,A5,A5+1,A5+2,A5+5,6+1,6+2,6+3,6+6
   FF           A1+4,A5+3,6+4
   YN           A5+5,6+6

External References
   ^DIC                A1+5
   YN^DICN             DEL+1
   ^DIE                2+2
   ENFF^PSGOEM         FF+1
   ENHLP^PSGOEM        A1+1,A1+3,A5+4,A5+6,6+5,6+7
   PROVCHK^PSJCLOZ     A2+3

*****   END   *****


PSGOE7   * *  114 Lines,  6232 Bytes, Checksum: B35767530
                                                  Jul 01, 2016@13:24:55 page 6
              958 bytes in comments
PSGOE7   ;BIR/CML3 - SELECT DRUG ;15 MAY 00 1:43 PM
         ;;5.0;INPATIENT MEDICATIONS;**9,26,34,52,55,50,87,111,181,254,267,260,2
          88,281,327**;16 DEC 97;Build 10
         ;
         ; Reference to ^PS(50.7 is supported by DBIA 2180
         ; Reference to ^PS(59.7 is supported by DBIA 2181
         ; Reference to ^PSDRUG( is supported by DBIA 2192
         ; Reference to ^TMP("PSODAOC",$J supported by DBIA 6071
         ;
         ; NFI-UD chgs for FR#: 1
         ; 
         ;S PSGDICS="U"_$S($D(PSJOERR):",I",1:"")
         S PSGDICS="U"
         ;
AD       ; Ask Drug
         K PSJDOSE,PSJDOX ;var array use in ^PSJDOSE
         K PSGODO,^TMP("PSJINTER",$J) D KILL^PSJBCMA5(+$G(PSJSYSP))
         K DIC S DIC="^PS(50.7,",DIC(0)="EMQZVT",D="B^C" I '$P(PSJSYSU,";",4) S 
          DIC("S")="I $$ENOISC^PSJUTL(Y,""U"")"
         E  D
         .I '$D(PSJDGCK) S DIC("T")="",DIC="^PSDRUG(",DIC("S")="I +$G(^PSDRUG(+Y
          ,2)),$P($G(^PSDRUG(+Y,2)),""^"",3)[""U"" S X(1)=+$G(^(""I"")) I $S('X(
          1):1,1:X(1)>DT)",D="B^C^VAPN^VAC^NDC^XATC"
         .I $D(PSJDGCK) S DIC("T")="",DIC="^PSDRUG(",DIC("S")="I +$G(^PSDRUG(+Y,
          2)),$$GCN^PSGOE7(+Y),$$PKGFLG^PSGOE7($P($G(^PSDRUG(+Y,2)),""^"",3)) S 
          X(1)=+$G(^(""I"")) I $S('X(1):1,1:X(1)>DT)",D="B^C^VAPN^VAC^NDC^XATC"
         ;
AD1      ;
         K PSGORD,PSJORD,PSJALLGY,PSGUSRX,^TMP("PSJINTER",$J),^PS(53.45,+$G(PSJS
          YSP),5),^PS(53.45,+$G(PSJSYSP),6)
         K ^TMP("PSODAOC",$J)
         S PSGORQF=0 R !!,"Select DRUG: ",X:DTIME I '$T W $C(7) S X="^"
         ; -- save off value of X in PSGUSRX so variable can be reliable checked
           at DO tag
         S PSGUSRX=X
         I $D(PSJDGCK) I ($G(PSJOCNT)'>1&(X="")) D  Q
         .W !!,"Not enough active profile drugs to perform drug check",!
         .K DIR S DIR(0)="E",DIR("A")="Press Return to Continue..." D ^DIR K DIR
           W @IOF
         I $D(PSJDGCK),X="" N PSGDGCKF S PSGDGCKF=1 G DGCKX
         I ("^"[X)!(X="") S PSGORQF=1 G DONE
         G:X?1"S."1.E DONE
         I X?1."?" W !!?2,"Select the medication you wish the patient to receive
          ." W:PSJSYSU<3 "  You should consult",!,"with your pharmacy before ord
          ering any non-formulary medication." W !
         D MIX^DIC1 G:X?1."?" AD1 G:"^"[X!(Y'>0) AD1 S (PSGDO,PSGDRG,PSGDRGN,PSG
          NEDFD,PSGPDRG,PSGPDRGN)=""
         I $D(PSJDGCK) I $$PSJSUPCK^PSJDGCK(+Y) G AD1
DGCKX    I $P(PSJSYSU,";",4) D  G DO
         .S:'$D(PSJDGCK) PSGDRG=+Y,PSGDRGN=Y(0,0)
         .S:$D(PSJDGCK)&'$D(PSGDGCKF) PSGDRG=+Y,PSGDRGN=Y(0,0)
         .S:$D(PSJDGCK)&$D(PSGDGCKF) PSGDRG=$P($$DGCKIEN^PSJDGCK(),";",2),PSGDRG
          N=$P($G(^PSDRUG(PSGDRG,0)),U)
         .D DIN^PSJDIN(+$G(^PSDRUG(PSGDRG,2)),PSGDRG)
         .I '$D(PSJDGCK) I $P(Y(0),"^",9) D NF S:Y>0 PSGDRG=+Y(0),PSGDRGN=Y(0,0)
           D SNFM
         .I $D(PSJDGCK)&'$D(PSGDGCKF) I $P(Y(0),"^",9) D NF S:Y>0 PSGDRG=+Y(0),P
          SGDRGN=Y(0,0) D SNFM
         .S PSGPDRG=+$G(^PSDRUG(PSGDRG,2)),PSGPDRGN=$$OINAME^PSJLMUTL(PSGPDRG)
         I '$D(PSJDGCK) S PSGPDRG=+Y,PSGPDRGN=$$OINAME^PSJLMUTL(PSGPDRG)
         I $D(PSJDGCK)&'$D(PSGDGCKF) S PSGPDRG=+Y,PSGPDRGN=$$OINAME^PSJLMUTL(PSG
          PDRG)
         ;F Q=1:1:$L(PSGDICS) S X=$P(PSGDICS,",",Q) Q:X=""  S PSJLUAPP=$O(^PS(50
          .3,PSGPDRG,1,"B",X,0)) I PSJLUAPP S X=$G(^PS(50.3,PSGPDRG,1,PSJLUAPP,0
          )) Q
         S X=$O(^PSDRUG("ASP",PSGPDRG,0)) I X,'$O(^(X)) S PSGDRG=X,PSGDRGN=$$END
          DN^PSGMI(X)
         ;
DO       ; dosage ordered
         N PSJALLGY,PSGFLG
         S PSGNEDFD=$$GTNEDFD("U",PSGPDRG)
         ; -- if PSGDGCKF is set, CK action is being used and no DRUG was entere
          d, do not set PSJALLGY array
         I $G(PSGDRG),$P(PSJSYSU,";",4) S:'$G(PSGDGCKF) PSJALLGY(PSGDRG)=$S($G(P
          SGUSRX)=""&($G(PSGDRG)):"",1:"P") D ENDDC^PSGSICHK(PSGP,PSGDRG) G:$G(P
          SGORQF) AD
         ;;START NCC T4 MODS >> 327*RJS
         I $P(PSJSYSU,";",4),$P($G(^PSDRUG(PSGDRG,"CLOZ1")),"^")="PSOCLO1" W !,"
          Now doing Clozapine Order checks.  Please wait...",! D
         . N RTN,ANQX
         . S ANQX=1,RTN=$P($G(^PSDRUG(PSGDRG,"CLOZ1")),U)
         . D:$L(RTN) ^@RTN
         . S:$G(ANQX) PSJORQF=1
         G:PSJORQF AD
         I '$P(PSJSYSU,";",4) S PSGX=PSGPDRG D  G:$G(ANQX) AD
         .S PSGDRG=0 F  S PSGDRG=$O(^PSDRUG("ASP",PSGPDRG,PSGDRG)) Q:'PSGDRG!($G
          (PSGFLG))  D
         ..I $G(^PSDRUG(PSGDRG,0))["CLOZAPINE" D
         ...N RTN
         ...S ANQX=1,RTN=$P($G(^PSDRUG(PSGDRG,"CLOZ1")),U)
         ...I $L(RTN) D ^@RTN S PSGFLG=1
         ...Q:$G(ANQX)
         S PSGDO=""
         ;; END NCC T4 MODS << 327*RJS
         ;
DONE     ;
         K DIC,%,%Y,PSGDICS,PSJLUAPP,Q1,Q2,Q3,Z,PSJALLGY,PSGUSRX Q
         ;
         ;
NF       ;
         S Y=0 W $C(7),!!,"PLEASE NOTE: The selected item is not currently on yo
          ur medical center's",!?13,"formulary." Q:'$P(PSJSYSU,";",2)
         N CNT S CNT=0 F Q1=0:0 S Q1=$O(^PSDRUG(PSGDRG,65,Q1)) Q:'Q1  I $$CHKDRG
          (+$G(^(Q1,0))) S CNT=CNT+1
         I CNT=0 W !!,"There are no formulary alternatives entered for this item
          ." W:PSJSYSU>2 "  You should consult",!,"with your pharmacy before ord
          ering this item." S Y=0 Q
         I CNT=1 S Q1=$O(^PSDRUG(PSGDRG,65,0)),Q1=+$G(^(Q1,0)),Q3=$P(^PSDRUG(Q1,
          0),"^") W !!,Q3," has been entered as a formulary " W:$X>67 ! W "alter
          native."
         I  F Q=1:1 S %=2 W !!,"Is ",$S(Q=1:"this",1:Q3)," acceptable" D YN^DICN
           Q:%  D NFOH
         I CNT=1 S:%=1 (Y(0),Y)=Q1,Y(0,0)=Q3 S:%<0 Y=-1 Q
         K DA,DIC S DA(1)=PSGDRG,DIC="^PSDRUG("_PSGDRG_",65,",DIC(0)="AEMQZ",DIC
          ("A")="Select FORMULARY ALTERNATIVE: " W ! D ^DIC K DIC Q
         ;
NFOH     ;
         S X="Answer 'YES' to order this formulary alternative ("_Q3_") for the 
          patient instead of the non-formulary item originally selected.  Answer
           'NO' to use the drug originally selected."
         W !!?2 F Y=1:1:$L(X," ") S Z=$P(X," ",Y) W:$L(Z)+$X+2>IOM ! W Z," "
         Q
CHKDRG(DRG) --
          ; Determine if dispense drug is valid for Unit Dose.
         I $D(^PSDRUG(DRG,0)),$P($G(^(2)),U,3)["U" S X=+$G(^("I")) I 'X!(X>DT) Q
           DRG
         Q 0
         ;
SNFM     ; show non-formulary message
         S Y=1 Q:PSJSYSU=3!'$O(^PS(59.7,1,21,0))  W $C(7),! S Q=0 F  S Q=$O(^PS(
          59.7,1,21,Q)) Q:'Q  W !,$G(^(Q,0))
         W ! D READ^PSJUTL S Y=1 Q
         ;
GTNEDFD(APP,PDRG) --
          ; Find defaults from Orderable Item.
         Q $P($G(^PS(50.7,+PDRG,0)),"^",5,8)
         N Q,X S X=""
         F Q=1:1:$L(APP) S X=$E(APP,Q) Q:X=""  S X=$O(^PS(50.3,+PDRG,1,"B",X,0))
           I X S X=$P($G(^PS(50.3,+PDRG,1,X,0)),"^",5,8) Q
         Q X
         ;
PKGFLG(PKF) --
          ;Return 0 for not in range of acceptable package flags, 1 for within r
a
          nge
         I $S(PKF["U":1,1:0) Q 1
         I $S(PKF["I":1,1:0) Q 1
         Q 0
         ;
GCN(PSGIENID) --
          ;Return 0 for not matched, 1 for matched with no GCNSEQNO, 1^1 for mat
c
          hed with a GCNSEQNO
         N PSGNDFID,PSGGCNPT,PSGGCNID
         S PSGNDFID=$P($G(^PSDRUG(PSGIENID,"ND")),"^"),PSGGCNPT=$P($G(^PSDRUG(PS
          GIENID,"ND")),"^",3)
         I 'PSGNDFID!('PSGGCNPT) Q 0
         S PSGGCNID=$$PROD0^PSNAPIS(PSGNDFID,PSGGCNPT)
         I $P(PSGGCNID,"^",7) Q PSGIENID_";"_PSGNDFID_";"_$P(PSGGCNID,"^",7)
         Q PSGIENID_";"_PSGNDFID

*****   INDEX OF PSGOE7   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   %            DONE+1!,NF+5*,NF+6
   %Y           DONE+1!
   ANQX         DO+7~,DO+8*,DO+10,DO+12,DO+16*,DO+18
   APP          GTNEDFD~,GTNEDFD+3
   CNT          NF+2~*,NF+3,NF+4,NF+6
>> D            AD+3*,AD+5*,AD+6*
   DA           NF+7!
   DA(1         NF+7*
   DIC          AD+3!*,AD+5*,AD+6*,DONE+1!,NF+7!*
   DIC("A"      NF+7*
   DIC("S"      AD+3*,AD+5*,AD+6*
   DIC("T"      AD+5*,AD+6*
   DIC(0        AD+3*,NF+7*
   DIR          AD1+8!
   DIR("A"      AD1+8*
   DIR(0        AD1+8*
   DRG          CHKDRG~,CHKDRG+1
   DT           CHKDRG+1
   DTIME        AD1+3
   IOF          AD1+8
   IOM          NFOH+2
   PDRG         GTNEDFD~,GTNEDFD+1,GTNEDFD+3
   PKF          PKGFLG~,PKGFLG+1,PKGFLG+2
   PSGDGCKF     AD1+9~*,DGCKX+2,DGCKX+3,DGCKX+6,DGCKX+9,DO+4
   PSGDICS      PSGOE7+11*,DONE+1!
>> PSGDO        AD1+13*,DO+19*
>> PSGDRG       AD1+13*,DGCKX+1*,DGCKX+2*,DGCKX+3*,DGCKX+4,DGCKX+5*,DGCKX+6*
                DGCKX+7,DGCKX+11*,DO+4,DO+6,DO+8,DO+13*,DO+14,DO+16,NF+2,NF+4
                NF+7
>> PSGDRGN      AD1+13*,DGCKX+1*,DGCKX+2*,DGCKX+3*,DGCKX+5*,DGCKX+6*,DGCKX+11*
   PSGFLG       DO+1~,DO+13,DO+17*
   PSGGCNID     GCN+1~,GCN+4*,GCN+5
   PSGGCNPT     GCN+1~,GCN+2*,GCN+3,GCN+4
   PSGIENID     GCN~,GCN+2,GCN+5,GCN+6
   PSGNDFID     GCN+1~,GCN+2*,GCN+3,GCN+4,GCN+5,GCN+6
>> PSGNEDFD     AD1+13*,DO+2*
   PSGODO       AD+2!
   PSGORD       AD1+1!
>> PSGORQF      AD1+3*,AD1+10*,DO+4
>> PSGP         DO+4
>> PSGPDRG      AD1+13*,DGCKX+7*,DGCKX+8*,DGCKX+9*,DGCKX+11,DO+2,DO+12,DO+13
>> PSGPDRGN     AD1+13*,DGCKX+7*,DGCKX+8*,DGCKX+9*
   PSGUSRX      AD1+1!,AD1+5*,DO+4,DONE+1!
>> PSGX         DO+12*
   PSJALLGY     AD1+1!,DO+1~,DONE+1!
   PSJALLGY(    DO+4*
>> PSJDGCK      AD+5,AD+6,AD1+6,AD1+9,AD1+14,DGCKX+1,DGCKX+2,DGCKX+3,DGCKX+5
                DGCKX+6,DGCKX+8,DGCKX+9
   PSJDOSE      AD+1!
   PSJDOX       AD+1!
   PSJLUAPP     DONE+1!
>> PSJOCNT      AD1+6
   PSJORD       AD1+1!
>> PSJORQF      DO+10*,DO+11
>> PSJSYSP      AD+2,AD1+1
>> PSJSYSU      AD+3,AD1+12,DGCKX,DO+4,DO+6,DO+12,NF+1,NF+3,SNFM+1
   Q            NF+5*,SNFM+1*,GTNEDFD+2~,GTNEDFD+3*
   Q1           DONE+1!,NF+2*,NF+4*,NF+6
   Q2           DONE+1!
   Q3           DONE+1!,NF+4*,NF+5,NF+6,NFOH+1
   RTN          DO+7~,DO+8*,DO+9,DO+15~,DO+16*,DO+17
   U            DGCKX+3,DO+8,DO+16,CHKDRG+1
   X            AD1+3*,AD1+5,AD1+6,AD1+9,AD1+10,AD1+11,AD1+12,AD1+13,DGCKX+11*
                NFOH+1*,NFOH+2,CHKDRG+1*,GTNEDFD+2~*,GTNEDFD+3*,GTNEDFD+4
>> Y            AD1+13,AD1+14,DGCKX+1,DGCKX+2,DGCKX+5,DGCKX+6,DGCKX+8,DGCKX+9
                NF+1*,NF+3*,NF+6*,NFOH+2*,SNFM+1*,SNFM+2*
>> Y(0          DGCKX+1,DGCKX+2,DGCKX+5,DGCKX+6,NF+6*
   Z            DONE+1!,NFOH+2*

Global Variables  ( * Changed  ! Killed)
   ^PS(50.3            GTNEDFD+3
   ^PS(50.7            GTNEDFD+1
   ^PS(53.45           AD1+1!
   ^PS(59.7            SNFM+1
   ^PSDRUG(            DGCKX+3,DGCKX+4,DGCKX+7,DO+6,DO+8,DO+14,DO+16,NF+2,NF+4
                       CHKDRG+1,GCN+2
   ^PSDRUG("ASP"       DGCKX+11,DO+13
   ^TMP("PSJINTER"     AD+2!,AD1+1!
   ^TMP("PSODAOC"      AD1+2!

Naked Globals
   ^(           DGCKX+11,NF+2,NF+4,SNFM+1
   ^("I"        CHKDRG+1
   ^(2          CHKDRG+1

Cache Objects
   NONE

Marked Items
   NONE

Label References
   $$CHKDRG     NF+2
   $$GTNEDFD    DO+2
   AD           DO+4,DO+11,DO+12
   AD1          AD1+13,AD1+14
   DGCKX        AD1+9
   DO           DGCKX
   DONE         AD1+10,AD1+11
   NF           DGCKX+5,DGCKX+6
   NFOH         NF+5
   SNFM         DGCKX+5,DGCKX+6

External References
   ^@(                 DO+9,DO+17
   ^DIC                NF+7
   MIX^DIC1            AD1+13
   YN^DICN             NF+5
   ^DIR                AD1+8
   $$ENDDN^PSGMI       DGCKX+11
   ENDDC^PSGSICHK      DO+4
   KILL^PSJBCMA5       AD+2
   $$DGCKIEN^PSJDGCK   DGCKX+3
   $$PSJSUPCK^PSJDGCK  AD1+14
   DIN^PSJDIN          DGCKX+4
   $$OINAME^PSJLMUTL   DGCKX+7,DGCKX+8,DGCKX+9
   READ^PSJUTL         SNFM+2
   $$PROD0^PSNAPIS     GCN+4

*****   END   *****


PSGOE8   * *  152 Lines,  7936 Bytes, Checksum: B53571835
                                                  Jul 01, 2016@13:24:55 page 7
              812 bytes in comments
PSGOE8   ;BIR/CML3-EDIT ORDERS IN 53.1 ; 7/6/11 9:44am
         ;;5.0;INPATIENT MEDICATIONS ;**47,50,65,72,110,111,188,192,113,223,269,
          287,327**;16 DEC 97;Build 10
         ;
         ; Reference to ^PS(50.7 is supported by DBIA# 2180
         ; Reference to ^PS(51.1 is supported by DBIA 2177
         ; Reference to ^PS(51.2 is supported by DBIA# 2178
         ; Reference to ^PSDRUG is supported by DBIA# 2192
         ;
101      ;Orderable Item
         S MSG=0,F2=101,PSGOOPD=PSGPD,PSGOOPDN=PSGPDN S:PSGOEEF(F2) BACK="101^PS
          GOE8"
         S %=1 I $P(PSJSYSU,";",3)>1 W !!,$C(7),"WARNING!  If you change the dru
          g of an order, the Dosage Ordered and Dispense",!,"Drug(s) are deleted
          ." F  W !,"Do you wish to continue" S %=2 D YN^DICN Q:%
         I %'=1 G DONE
         ;; START NCC T4 MODS >> 327*RJS
A101     ;
         I $$PNDREN($G(PSGORD)) D  Q
         . W !!?5,"Orderable Item may not be edited at this point." D PAUSE^VALM
          1
         W !,"ORDERABLE ITEM: ",$S(PSGPD:PSGPDN_"// ",1:"") R X:DTIME I X="^"!'$
          T W:'$T $C(7) S PSGOEE=0 G DONE
A201     I X="",PSGPD S X=PSGPDN I PSGPD'=PSGPDN,$D(^PS(50.7,PSGPD,0)) G:'$G(ANQ
          X) DONE
         S PSGPDOLD=PSGPD,PSGPDNOLD=PSGPDN,PSGPDRGOLD=PSGPDRG
         I $S(X="@":1,X]"":0,1:'PSGPD) W $C(7),"  (Required)" S X="?" D ENHLP^PS
          GOEM(53.1,101) G A101
         I X?1."?" D ENHLP^PSGOEM(53.1,101)
         I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A101
         ;BHW;PSJ*5.0*192;Modify ^DIC call to use MIX^DIC and only B/C cross-ref
          erences
         K DIC,D S DIC="^PS(50.7,",DIC(0)="EMQZ",DIC("S")="I $$ENOISC^PSJUTL(Y,"
          "U"")",D="B^C" D MIX^DIC1 K DIC,D I Y'>0 G A101
         F  S %=2 D DH,YN^DICN Q:%
         I %'=1 G A101
         S (PSGPDRG,PSGPD)=+Y,(PSGPDN,PSGPDRGN)=$$OINAME^PSJLMUTL(PSGPDRG)
         S PSGNEDFD=$$GTNEDFD^PSGOE7("U",PSGPDRG)
         S PSGPDNX=1,PSGDO="",(PSGPDRG,PSGPD)=+Y,(PSGPDN,PSGPDRGN)=$$OINAME^PSJL
          MUTL(PSGPDRG) K ^PS(53.45,PSJSYSP,2) S X=$O(^PSDRUG("ASP",PSGPD,0)) I 
          X,'$O(^(X)) D
         .S ^PS(53.45,PSJSYSP,2,0)="^53.4502P^1^1",^(1,0)=X,^PS(53.45,PSJSYSP,2,
          "B",X,1)=""
         S PSGDRGTMP=X
         D ENDRG^PSGOEF1(PSGPD,0)
         I $D(^PSDRUG("ACLOZ",PSGDRGTMP)) D
         .D CLOZ^PSJCLOZ(DFN,PSGDRGTMP)
         I $G(ANQX) W ! S X=$E(PSGPDNOLD,0,4),PSGPDN=PSGPDNOLD,PSGPD=PSGPDOLD,PS
          GPDRG=PSGPDRGOLD K ANQX,PSGDRGTMP,PSGPDOLD,PSGPDNOLD,PSGPDRGOLD G A201
         G DONE
         ;; END NCC T4 MODS >> 327*RJS
         ;
109      ; dosage ordered
         S MSG=0,F2=109 S:PSGOEEF(F2) BACK="109^PSGOE8"
A109     ;
         I $$PNDREN($G(PSGORD)) D  Q
         . W !!?5,"Dosage may not be edited at this point." D PAUSE^VALM1
         S PSGOEEF(F2)=PSGOEE
         D EDITDOSE^PSJDOSE S X=PSGDO G DONE
         W !,"DOSAGE ORDERED: ",$S(PSGDO]"":PSGDO_"// ",1:"") R X:DTIME I X="^"!
          '$T W:'$T $C(7) S PSGOEE=0 G DONE
         I X=""&(PSGDO]"") S X=PSGDO
         I $$CHECK(PSJSYSP)&(X="")&(PSGDO']"") W $C(7),"    (Required) " G A109
         I $$CHECK(PSJSYSP)&(X="@") W $C(7),"      (Required) " G A109
         I '$$CHECK(PSJSYSP)&(X="@") S PSGDO="" G DONE
         I X?1."?" D ENHLP^PSGOEM(53.1,109) G A109
         I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A109
         I $E(X,$L(X))=" " F  S X=$E(X,1,$L(X)-1) Q:$E(X,$L(X))'=" "
         I $S(X?.E1C.E:1,$L(X)>20:1,X="":0,X["^":1,X?1.P:1,1:X=+X) W $C(7),"  ",
          $S(X?1.P!(X=""):"(Required)",1:"??") D ENHLP^PSGOEM(53.1,109) G A109
         S PSGDO=X G DONE
         ;
3        ; med route
         S MSG=0,F2=3 S:PSGOEEF(F2) BACK="3^PSGOE8"
A3       I $$PNDREN($G(PSGORD)) D  Q
         . W !!?5,"Med Route may not be edited at this point." D PAUSE^VALM1
         W !,"MED ROUTE: ",$S(PSGMR:PSGMRN_"// ",1:"") R X:DTIME I X="^"!'$T W:'
          $T $C(7) S PSGOEE=0 G DONE
         I X="",PSGMR S X=PSGMRN I PSGMR'=PSGMRN,$D(^PS(51.2,PSGMR,0)) W "  "_$P
          (^(0),"^",3) G DONE
         I $S(X="@":1,X]"":0,1:'PSGMR) W $C(7),"  (Required)" S X="?" D ENHLP^PS
          GOEM(53.1,3) G A3
         I X?1."?" D ENHLP^PSGOEM(53.1,3)
         I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A3
         K DIC S DIC="^PS(51.2,",DIC(0)="EMQZ",DIC("S")="I $P(^(0),""^"",4)" D ^
          DIC K DIC I Y'>0 G A3
         S PSGMR=+Y,PSGMRN=Y(0,0) G DONE
         ;
26       ; schedule
         S MSG=0,F2=26 S:PSGOEEF(F2) BACK="26^PSGOE8"
A26      I $$PNDREN($G(PSGORD)) D  Q
         . W !!?5,"Schedule may not be edited at this point." D PAUSE^VALM1
         W !,"SCHEDULE: ",$S(PSGSCH]"":PSGSCH_"// ",1:"") R X:DTIME I X="^"!'$T 
          W:'$T $C(7) S PSGOEE=0 G DONE
         S:X="" X=PSGSCH,PSGSCH="" I "@"[X W $C(7),"  (Required)" S X="?" D ENHL
          P^PSGOEM(53.1,26) G A26
         S DOW=0 I $$DOW^PSIVUTL($$ENLU^PSGMI(X)) S DOW=1
         I X?1."?" D ENHLP^PSGOEM(53.1,26) G A26
         I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A26
         ;BHW;PSJ*5*188;Add flag and IEN return variable for PSGS0 (PSJ*5*134), 
          Highlight Admin Times if they changed.
         N PSGOES,PSJSLUP,PSGSFLG S PSJSLUP=1,PSGSFLG=1 D EN^PSGS0 I '$D(X) W $C
          (7),"  ??" S X="?" D ENHLP^PSGOEM(53.1,26) G A26
         I X'=PSGSCH D
         . N XX
         . S PSGSCH=X
         . I PSGS0Y'=PSGAT S PSGAT=PSGS0Y  ;Change so that any schedule change w
          ill adjust the type and default the admin times - DRF
         . D  ;Change schedule type to agree with schedule
         .. I $G(DOW) S PSGST="C",PSGSTN=$$ENSTN^PSGMI(PSGST) Q
         .. I (PSGSCH[" PRN")!(PSGSCH="PRN") I $$PRNOK^PSGS0(PSGSCH) S PSGOST=PS
          GST,PSGST="P",PSGSTN=$$ENSTN^PSGMI(PSGST) Q
         .. I PSGSCH]"" S XX=+$O(^PS(51.1,"AC","PSJ",PSGSCH,0))
         .. S PSGOST=$G(PSGST),PSGST=$P($G(^PS(51.1,XX,0)),"^",5) I PSGST="D" S 
          PSGST="C"  ;DOW schedules are converted to Continuous
         .. S PSGSTN=$$ENSTN^PSGMI(PSGST)
         . I $G(PSJSYSW0),($P(PSJSYSW0,U,5)'=2),'$G(PSGEFN(8)) W !!,"NOTE: This 
          may cause the Admin Times and the Start Time to be out of sync."
         . W !!,"NOTE: This change in schedule also changes the ADMIN TIMES and 
          SCHEDULE TYPE.",!
         . S MSG=1 S:'$G(PSGOEEF(39)) PSGOEEF(39)=1  ;*287 - Prevent infinite lo
          op editing admin times
         . I $G(PSJNEWOE) D PAUSE^VALM1
         I PSGST="O" S PSGOEEF(7)=1
         G DONE
         ;
7        ; schedule type
         S MSG=0,F2=7 S:PSGOEEF(F2) BACK="7^PSGOE8"
A7       W !,"SCHEDULE TYPE: "_$S(PSGSTN]"":PSGSTN_"// ",1:"") R X:DTIME S X=$TR
          (X,"coprocf","COPROCF") I X="^"!'$T S PSGOEE=0 W $C(7) G DONE
         I X="" S X=PSGST,PSGSTN=$$ENSTN^PSGMI(X) W:PSGSTN]"" "  ",PSGSTN G DONE
         S:X="F" X="R"
         I ",?,??,C,O,OC,P,R,"'[(","_X_",") W " ??" G A7
         I $$PRNOK^PSGS0($G(PSGSCH)),X="C" W "  ??" G A7
         I X="@"!(X?1."?") W:X="@" $C(7),"  (Required)" S:X="@" X="?" D ENHLP^PS
          GOEM(53.1,7) G A7
         I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A7
         ;*223 Don't allow O sched type on C orders
         I X="O",$$SCHTP(PSGSCH)'="O" W !,"  SCHEDULE ("_PSGSCH_") is not a ONE 
          TIME Schedule." G A7
         ;*269 Don't allow C sched type on O orders
         I X="C",$$SCHTP(PSGSCH)="O" W !,"  SCHEDULE ("_PSGSCH_") is not a CONTI
          NUOUS Schedule." G A7
         S PSGOST=PSGST
         S PSGST=X,PSGSTN=$$ENSTN^PSGMI(X) W:PSGSTN]"" "  ",PSGSTN
         I X="P",$G(PSGAT)]"" S PSGOAT=PSGAT S PSGAT="" D
         .W !!,"NOTE: This change in schedule type also changes the ADMIN TIMES.
          ",!
         .S MSG=1,PSGOEEF(39)=1
         .I $G(PSJNEWOE) D PAUSE^VALM1
         ;
DONE     ;
         I PSGOEE G:'PSGOEEF(F2) @BACK S PSGOEE=PSGOEEF(F2)
         K PSGDRGTMP,PSGPDOLD,PSGPDNOLD,PSGPDRGOLD
         K F,F0,F2 Q
         ;
DEL      ; delete entry
         W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W $C(7),"  <NOTH
          ING DELETED>"
         Q
         ;
DH       ;
         W !!?2,"When the drug of an order is changed, the Dosage Ordered and Di
          spense Drug(s)",!,"for the order are no longer valid, and therefore de
          leted from the order.",!,"If possible, a new corresponding dispense dr
          ug will be added to the order."
         W !!?2,"Answer 'YES' to continue with this change.  Answer 'NO' to sele
          ct another",!,"drug or to accept the drug as it was.  Enter an '^' the
           exit this edit." Q
         ;
CHECK(PSJSYSP) --
          ; Check to see if multiple dispense drugs
         ; Input  -     PSJSYSP
         ; Returns  0 = only one.
         ;          1 = more than one
         ; Checks Inactive Date and doesn't count if < or = today.
         N PSJRSB,PSJINACT,PSJRBCNT S PSJRBCNT=0
         F PSJRSB=0:0 S PSJRSB=$O(^PS(53.45,PSJSYSP,2,PSJRSB)) Q:'PSJRSB  D
         .S PSJINACT=$P(^PS(53.45,PSJSYSP,2,PSJRSB,0),"^",3)
         .I (PSJINACT="")!((PSJINACT>0)&(PSJINACT>DT)) D
         ..S PSJRBCNT=$S('$D(PSJRBCNT):1,1:PSJRBCNT+1)
         Q $S(PSJRBCNT>1:1,1:0)
         ;
PNDREN(PNDON) --
          ;
         I PNDON'["P" Q 0
         S RNWL="^PS(53.1,"_+PNDON_",0)" S RNWL=$G(@(RNWL)) S RNWL=$S($P(RNWL,"^
          ",24)="R":1,1:0)
         Q RNWL
         ;
SCHTP(SCH) --
          ; *223 Return SCHedule type
         N X I SCH="" Q ""
         S X=$O(^PS(51.1,"APPSJ",SCH,0))
         Q:'$G(X) ""
         Q $P(^PS(51.1,X,0),"^",5)
         ;

*****   INDEX OF PSGOE8   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
>> %            101+2*,101+3,A201+7*,A201+8,DEL+1*
   ANQX         A201,A201+17!
>> BACK         101+1*,109+1*,3+1*,26+1*,7+1*,DONE+1
   D            A201+6!*
>> DFN          A201+16
   DIC          A201+6!*,A3+7!*
   DIC("S"      A201+6*,A3+7*
   DIC(0        A201+6*,A3+7*
>> DOW          A26+4*,A26+14
   DT           CHECK+8
   DTIME        A101+3,A109+5,A3+2,A26+2,A7
   F            DONE+3!
   F0           DONE+3!
   F2           101+1*,109+1*,A109+3,3+1*,26+1*,7+1*,DONE+1,DONE+3!
>> MSG          101+1*,109+1*,3+1*,26+1*,A26+21*,7+1*,A7+15*
   PNDON        PNDREN~,PNDREN+1,PNDREN+2
>> PSGAT        A26+12*,A7+13*
>> PSGDO        A201+11*,A109+4,A109+5,A109+6,A109+7,A109+9*,A109+14*
   PSGDRGTMP    A201+13*,A201+15,A201+16,A201+17!,DONE+2!
>> PSGEFN(8     A26+19
>> PSGMR        A3+2,A3+3,A3+4,A3+8*
>> PSGMRN       A3+2,A3+3,A3+8*
>> PSGNEDFD     A201+10*
>> PSGOAT       A7+13*
>> PSGOEE       A101+3*,A109+3,A109+5*,A3+2*,A26+2*,A7*,DONE+1*
>> PSGOEEF(     101+1,109+1,A109+3*,3+1,26+1,7+1,DONE+1
>> PSGOEEF(39   A26+21*,A7+15*
>> PSGOEEF(7    A26+23*
   PSGOES       A26+8~
>> PSGOOPD      101+1*
>> PSGOOPDN     101+1*
>> PSGORD       A101+1,A109+1,A3,A26
>> PSGOST       A26+15*,A26+17*,A7+11*
>> PSGPD        101+1,A101+3,A201,A201+1,A201+2,A201+9*,A201+11*,A201+14
                A201+17*
>> PSGPDN       101+1,A101+3,A201,A201+1,A201+9*,A201+11*,A201+17*
   PSGPDNOLD    A201+1*,A201+17!,DONE+2!
>> PSGPDNX      A201+11*
   PSGPDOLD     A201+1*,A201+17!,DONE+2!
>> PSGPDRG      A201+1,A201+9*,A201+10,A201+11*,A201+17*
>> PSGPDRGN     A201+9*,A201+11*
   PSGPDRGOLD   A201+1*,A201+17!,DONE+2!
>> PSGS0Y       A26+12
>> PSGSCH       A26+2,A26+3*,A26+9,A26+11*,A26+15,A26+16,A7+4,A7+8,A7+10
   PSGSFLG      A26+8~*
>> PSGST        A26+14*,A26+15*,A26+17*,A26+18,A26+23,A7+1,A7+11,A7+12*
>> PSGSTN       A26+14*,A26+15*,A26+18*,A7,A7+1*,A7+12*
   PSJINACT     CHECK+5~,CHECK+7*,CHECK+8
>> PSJNEWOE     A26+22,A7+16
   PSJRBCNT     CHECK+5~*,CHECK+9*,CHECK+10
   PSJRSB       CHECK+5~,CHECK+6*,CHECK+7
   PSJSLUP      A26+8~*
   PSJSYSP      A201+11,A201+12,A109+7,A109+8,A109+9,CHECK~,CHECK+6,CHECK+7
>> PSJSYSU      101+2
>> PSJSYSW0     A26+19
>> RNWL         PNDREN+2*,PNDREN+3
   SCH          SCHTP~,SCHTP+1,SCHTP+2
   U            A26+19
   X            A101+3*,A201*,A201+2*,A201+3,A201+4,A201+11*,A201+12,A201+13
                A201+17*,A109+4*,A109+5*,A109+6*,A109+7,A109+8,A109+9,A109+10
                A109+11,A109+12*,A109+13,A109+14,A3+2*,A3+3*,A3+4*,A3+5,A3+6
                A26+2*,A26+3*,A26+4,A26+5,A26+6,A26+8*,A26+9,A26+11
                A7*,A7+1*,A7+2*,A7+3,A7+4,A7+5*,A7+6,A7+8,A7+10,A7+12,A7+13
                SCHTP+1~,SCHTP+2*,SCHTP+3,SCHTP+4
   XX           A26+10~,A26+16*,A26+17
>> Y            A201+4,A201+6,A201+9,A201+11,A109+11,A3+6,A3+7,A3+8,A26+6,A7+6
>> Y(0          A3+8

Global Variables  ( * Changed  ! Killed)
   ^PS(50.7            A201
   ^PS(51.1            A26+16,A26+17,SCHTP+2,SCHTP+4
   ^PS(51.2            A3+3
   ^PS(53.45           A201+11!,A201+12*,CHECK+6,CHECK+7
   ^PSDRUG("ACLOZ"     A201+15
   ^PSDRUG("ASP"       A201+11

Naked Globals
   ^(           A201+11
   ^(0          A3+3
   ^(1          A201+12*

Cache Objects
   NONE

Marked Items
   NONE

Label References
   $$CHECK      A109+7,A109+8,A109+9
   $$PNDREN     A101+1,A109+1,A3,A26
   $$SCHTP      A7+8,A7+10
   @(           A201+4,A109+11,A3+6,A26+6,A7+6,DONE+1
   A101         A201+2,A201+4,A201+6,A201+8
   A109         A109+7,A109+8,A109+10,A109+11,A109+13
   A201         A201+17
   A26          A26+3,A26+5,A26+6,A26+8
   A3           A3+4,A3+6,A3+7
   A7           A7+3,A7+4,A7+5,A7+6,A7+8,A7+10
   DH           A201+7
   DONE         101+3,A101+3,A201,A201+18,A109+4,A109+5,A109+9,A109+14,A3+2
                A3+3,A3+8,A26+2,A26+24,A7,A7+1

External References
   ^DIC                A3+7
   MIX^DIC1            A201+6
   YN^DICN             101+2,A201+7,DEL+1
   $$ENLU^PSGMI        A26+4
   $$ENSTN^PSGMI       A26+14,A26+15,A26+18,A7+1,A7+12
   $$GTNEDFD^PSGOE7    A201+10
   ENFF^PSGOE82        A201+4,A109+11,A3+6,A26+6,A7+6
   ENDRG^PSGOEF1       A201+14
   ENHLP^PSGOEM        A201+2,A201+3,A109+10,A109+13,A3+4,A3+5,A26+3,A26+5
                       A26+8,A7+5
   $$PRNOK^PSGS0       A26+15,A7+4
   EN^PSGS0            A26+8
   $$DOW^PSIVUTL       A26+4
   CLOZ^PSJCLOZ        A201+16
   EDITDOSE^PSJDOSE    A109+4
   $$OINAME^PSJLMUTL   A201+9,A201+11
   PAUSE^VALM1         A101+2,A109+2,A3+1,A26+1,A26+22,A7+16

*****   END   *****


PSGOE81  * *  116 Lines,  6829 Bytes, Checksum: B40027816
                                                  Jul 01, 2016@13:24:55 page 8
              809 bytes in comments
PSGOE81  ;BIR/CML3-NON-VERIFIED ORDER EDIT (CONT.) ; 7/20/12 12:43am
         ;;5.0;INPATIENT MEDICATIONS;**26,50,64,58,82,110,111,136,113,267,327**;
          16 DEC 97;Build 10
         ;
39       ; admin times
         S MSG=0,PSGF2=39 S:PSGOEEF(PSGF2) BACK="39^PSGOE81",ORIG=$G(PSGAT)
A39      I $$ODD^PSGS0(PSGS0XT)!(PSGST="P")!$$PRNOK^PSGS0($G(PSGSCH)) G DONE
         W !,"ADMIN TIMES: "_$S(PSGAT:PSGAT_"// ",1:"") R X:DTIME I X="^"!('$T) 
          W:'$T $C(7) S PSGOEE=0 S:X="^" (X,PSGAT)=ORIG G DONE
         I X="" S:(($G(PSGS0XT)="D")&'PSGS0Y) PSGOEE=0 S:$G(PSGAT) X=PSGAT
         I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A39
         I X=" "!(X?1."?") D ENHLP^PSGOEM(53.1,39) G A39
         I PSGS0XT="D"&'$G(X) I ((",P,R,")'[(","_$G(PSGST)_",")) D  G A39
         .W $C(7),"  ??" S X="?" W !,"This is a 'DAY OF THE WEEK' schedule and M
          UST have admin times." D ENHLP^PSGOEM(53.1,39)
         I X="@" D DEL G:%'=1 A39 S PSGAT="",X=""
         I $G(PSGS0XT),'$$ODD^PSGS0(PSGS0XT),$G(PSGS0XT)'="P",$G(PSGS0XT)'="OC",
          '$$PRNOK^PSGS0(PSGSCH),($G(PSGST)'="O") D TIMES I '$D(X) G A39
         I (($G(PSGST)="O")!($G(PSGST)="OC")) I (X="") S (PSGAT,PSGS0Y)=X G DONE
         D ENCHK^PSGS0 I '$D(X) W $C(7) G A39
         S PSGOAT=PSGAT
         S (PSGS0Y,PSGAT)=X G DONE
         ;
8        ; special instructions
         S MSG=0,PSGF2=8 S:PSGOEEF(PSGF2) BACK="8^PSGOE81"
A8       ; special instructions
         ;I $E($G(X))=U D ENFF^PSGOE82 G:Y>0 @Y G A8
         S PSGSI=$$EDITSI^PSJBCMA5($G(PSGP),$G(PSGORD)) I $G(PSGP),$G(PSGORD) I 
          '$$DIFFSI^PSJBCMA5(PSGP,PSGORD) S PSGOEE=0 G DONE
         S PSGSI=$S((PSGSI>0&(PSGSI<4)):$G(^PS(53.45,+PSJSYSP,5,1,0))_" "_$G(^PS
          (53.45,+PSJSYSP,5,2,0)),PSGSI>3:"Instructions too long. See Order View
           or BCMA for full text",1:"")
         I PSGSI]"" S PSGSI=$$ENBCMA^PSJUTL("U") G DONE
         Q
         ;
10       ; start date/time
         S MSG=0,PSGF2=10 S:PSGOEEF(PSGF2) BACK="10^PSGOE81"
A10      ; start date/time
         K PSGSDX N DUR,DURMIN,TMPFD
         I $G(PSGORD)["P",$G(PSGP) I $$LASTREN^PSJLMPRI(PSGP,PSGORD) D  Q
         . W !?5,"Start Date may not be edited at this point. " D PAUSE^VALM1
         W !,"START DATE/TIME: "_$S($P(PSGSDN,"^")]"":$P(PSGSDN,"^")_"// ",1:"")
           R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
         I X="",PSGSD W "  "_$P(PSGSDN,"^") G DONE
         I X="P" D ENPREV^PSGDL W:'$D(X) $C(7) G:'$D(X) A10 S PSGSD=+X,PSGSDN=$$
          ENDD^PSGMI(PSGSD)_"^"_$$ENDTC^PSGMI(PSGSD) W "  ",$P(PSGSDN,"^") G DON
          E
         I X="@"!(X?1."?") W:X="@" $C(7),"  (Required)" S:X="@" X="?" D ENHLP^PS
          GOEM(53.1,10)
         I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A10
         NEW TMPX S TMPX=X,X1=+$G(PSGLI),X2=-7 D C^%DTC K %DT S %DT="ERTX",%DT(0
          )=X,X=TMPX D ^%DT K %DT I Y'>0 D ENHLP^PSGOEM(53.1,10) G A10
         I PSGFD<Y W $C(7),!?5,"*** THE START DATE CANNOT BE AFTER THE STOP DATE
          ! ***",! S MSG=1 G A10
         S (PSGSDX,PSGSD,PSGNESD)=+Y,PSGSDN=$$ENDD^PSGMI(PSGSD)_"^"_$$ENDTC^PSGM
          I(PSGSD)
         I $G(PSGORD)["P",$G(PSGP) S DUR=$$GETDUR^PSJLIVMD(PSGP,+PSGORD,"P",1) I
           DUR]"" S DURMIN=$$DURMIN^PSJLIVMD(DUR) I DURMIN D
         . S TMPFD=$$FMADD^XLFDT(PSGSD,,,DURMIN) K:(TMPFD<PSGSD) TMPFD I $G(TMPF
          D) S PSGFD=TMPFD,PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC^PSGMI(PSGFD)
         G DONE
         ;
25       ; stop date
         S MSG=0,PSGF2=25 S:PSGOEEF(PSGF2) BACK="25^PSGOE81"
A25      ;
         K PSGFDX
         S PSGCFLG=0,PSGOLDED=PSGFD,PSGNEFDOLD=$G(PSGNEFD),PSGFDNOLD=PSGFDN
         W !,"STOP DATE/TIME: "_$S($P(PSGFDN,"^")]"":$P(PSGFDN,"^")_"// ",1:"") 
          R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
         I X="",PSGFD S X=$P(PSGFDN,"^") ;W "   "_$P(PSGFDN,"^")
         I $E(X)="^" D ENFF^PSGOE82 G:Y>0 @Y G A25
         I X="@"!(X?1."?") W:X="@" $C(7),"  (Required)" S:X="@" X="?" D ENHLP^PS
          GOEM(53.1,25)
         I X=+X,(X>0),(X'>2000000) G A25:'$$ENDL^PSGDL(PSGSCH,X) K PSGDLS S PSGD
          L=X W " ...dose limit..." D ENE^PSGDL
         K %DT S %DT="ERTX",%DT(0)=PSGSD D ^%DT K %DT G:Y'>0 A25 S (PSGFDX,PSGFD
          ,PSGNEFD)=+Y,PSGFDN=$$ENDD^PSGMI(PSGFD)_"^"_$$ENDTC^PSGMI(PSGFD)
         ;/RJS Begin changes for emergency registration of clozapine patient Set
           end date to start date + 4 days at midnight.
         I $G(^TMP("CLOZFLG",DFN)) D  G:X>4 A25
         .S X1=+Y,X2=PSGSD D ^%DTC
         .Q:X'>4
         .I X>4 D
         ..W !!?13,"*** EMERGENCY SUPPLY NOT TO EXCEED 4 DAYS! ***",!
         ..S $P(PSGFD,".",2)=2359,X1=PSGSD,X2=4 D C^%DTC S PSGFD=X
         ..S $P(PSGFDN,"^",1)=$$ENDD^PSGMI(PSGFD),$P(PSGFDN,"^",2)=PSGFD
         ;/RJS End changes for emergency registration of clozapine patient Set e
          nd date to start date + 4 days at midnight.
         ;/RJS Begin verify that stop date does not exceed maximum days supply b
          ased on lab frequency
A255     I $D(CLOZPAT),'$G(^TMP("CLOZFLG",DFN)) D  Q
         .N X,X1,X2
         .S X1=PSGFD,X2=$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:9
          0)
         .I $P(PSGFD,".",1)-$P(PSGSD,".",1)'=X2 S PSGCFLG=1,PSGFD=PSGOLDED,PSGNE
          FD=PSGNEFDOLD,PSGFDN=PSGFDNOLD W !!,"*** STOP DATE/TIME NOT TO EXCEED 
          "_X2_" DAYS! ***",! G A25
         .D C^%DTC S PSGFD=X,(PSGFDX,PSGFD,PSGNEFD)=+Y,PSGFDN=$$ENDD^PSGMI(PSGFD
          )_"^"_$$ENDTC^PSGMI(PSGFD)
         ;/RJS End verify that stop date does not exceed maximum days supply bas
          ed on lab frequency.
W25      ;
         N Z,MSG
         D DOSE I $G(Z)]"",Z>PSGNEFD D  G A25
         . S MSG(1)="There is no administration time that falls between the Star
          t Date/Time"
         . S MSG(2)="and the Stop Date/Time."
         . D EN^DDIOL(.MSG)
         I PSGFD<PSGDT W $C(7),!!?13,"*** WARNING! THE STOP DATE ENTERED IS IN T
          HE PAST! ***",! S MSG=1
         ;
DONE     ;
         ;Display Expected First Dose;BHW;PSJ*5*136
         D EFDNV^PSJUTL
         I PSGOEE G:'PSGOEEF(PSGF2) @BACK S PSGOEE=PSGOEEF(PSGF2)
         K ORIG,PSGCFLG,PSGOLDED,PSGNEFDOLD,PSGFDNOLD
         Q
         ;
FF       ; up-arrow to another field
         D ENFF^PSGOEM I Y>0,Y'=39,Y'=8,Y'=10,Y'=25 S Y=Y_"^PSGOE8"_$S("^109^13^
          3^7^26^"[("^"_Y_"^"):"",1:2) S:Y=2 FB=PSGF2_"^PSGOE81"
         Q
         ;
DEL      ; delete entry
         W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W $C(7),"  <NOTH
          ING DELETED>"
         Q
         ;
TIMES    ;At least one admin time, not more than interval allows.
         I ($G(PSGS0XT)'="O"),($G(PSGST)'="OC"),'$$PRNOK^PSGS0(PSGSCH) I X="" D 
          EN^DDIOL("This order requires at least one administration time.") K X 
          Q  ;No times
         N H,I,MAX
         I PSGSCH]"" I $D(^PS(51.1,"AC","PSJ",PSGSCH)) S H=+$O(^PS(51.1,"AC","PS
          J",PSGSCH,0)) S I=$P($G(^PS(51.1,H,0)),"^",3)
         I $G(PSGST)="O",$L(X,"-")>1 D EN^DDIOL("This is a One Time Order. Only 
          one administration time is permitted.") K X Q
         I $G(PSGST)="O" Q  ;Done validating One Time
         I +$G(I)=0 Q  ;No frequency - can not check frequency related items
         S MAX=1440/I
         I MAX<1,$L(X,"-")>1 D EN^DDIOL("This order requires one administration 
          time.") K X Q
         I MAX'<1,$L(X,"-")>MAX D EN^DDIOL("The number of admin times entered is
           greater than indicated by the schedule.") K X Q  ;Too many times
         I MAX'<1,$L(X,"-")<MAX D EN^DDIOL("The number of admin times entered is
           fewer than indicated by the schedule.")  ;Too few times
         Q
         ;
DOSE     ;Make certain at least one dose is given.
         N INFO,X
         S Z="",INFO=$S($G(PSGNESD):PSGNESD,1:$G(PSGSD))_U_($G(PSGNEFD))_U_($G(P
          SGSCH))_U_($G(PSGST))_U_($G(PSGDRG))_U_($G(PSGS0Y))
         Q:$G(PSGST)="OC"!($G(PSGST)="P")
         I '$L($G(PSGP)) N PSGP S PSGP=""
         S Z=$$ENQ^PSJORP2(PSGP,INFO)  ;Expected first dose.
         Q

*****   INDEX OF PSGOE81   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
>> %            A39+7,DEL+1*
   %DT          A10+9!*,A25+8!*
   %DT(0        A10+9*,A25+8*
>> BACK         39+1*,8+1*,10+1*,25+1*,DONE+3
>> CLOZPAT      A255,A255+2
>> DFN          A25+10,A255
   DTIME        A39+1,A10+4,A25+3
   DUR          A10+1~,A10+12*
   DURMIN       A10+1~,A10+12*,A10+13
>> FB           FF+1*
   H            TIMES+2~,TIMES+3*
   I            TIMES+2~,TIMES+3*,TIMES+6,TIMES+7
   INFO         DOSE+1~,DOSE+2*,DOSE+5
   MAX          TIMES+2~,TIMES+7*,TIMES+8,TIMES+9,TIMES+10
   MSG          39+1*,8+1*,10+1*,A10+10*,25+1*,W25+1~,W25+5,W25+6*
   MSG(1        W25+3*
   MSG(2        W25+4*
   ORIG         39+1*,A39+1,DONE+4!
>> PSGAT        39+1,A39+1*,A39+2,A39+7*,A39+9*,A39+11,A39+12*
   PSGCFLG      A25+2*,A255+3*,DONE+4!
>> PSGDL        A25+7*
   PSGDLS       A25+7!
>> PSGDRG       DOSE+2
>> PSGDT        W25+6
>> PSGF2        39+1*,8+1*,10+1*,25+1*,DONE+3,FF+1
>> PSGFD        A10+10,A10+13*,A25+2,A25+4,A25+8*,A25+15*,A25+16,A255+2,A255+3*
                A255+4*,W25+6
>> PSGFDN       A10+13*,A25+2,A25+3,A25+4,A25+8*,A25+16*,A255+3*,A255+4*
   PSGFDNOLD    A25+2*,A255+3,DONE+4!
   PSGFDX       A25+1!,A25+8*,A255+4*
>> PSGLI        A10+9
>> PSGNEFD      A25+2,A25+8*,A255+3*,A255+4*,W25+2,DOSE+2
   PSGNEFDOLD   A25+2*,A255+3,DONE+4!
>> PSGNESD      A10+11*,DOSE+2
>> PSGOAT       A39+11*
>> PSGOEE       A39+1*,A39+2*,A8+2*,A10+4*,A25+3*,DONE+3*
>> PSGOEEF(     39+1,8+1,10+1,25+1,DONE+3
   PSGOLDED     A25+2*,A255+3,DONE+4!
>> PSGORD       A8+2,A10+2,A10+12
   PSGP         A8+2,A10+2,A10+12,DOSE+4~*,DOSE+5
>> PSGS0XT      A39,A39+2,A39+5,A39+8,TIMES+1
>> PSGS0Y       A39+2,A39+9*,A39+12*,DOSE+2
>> PSGSCH       A39,A39+8,A25+7,TIMES+1,TIMES+3,DOSE+2
>> PSGSD        A10+5,A10+6*,A10+11*,A10+13,A25+8,A25+11,A25+15,A255+3,DOSE+2
>> PSGSDN       A10+4,A10+5,A10+6*,A10+11*
   PSGSDX       A10+1!,A10+11*
>> PSGSI        A8+2*,A8+3*,A8+4*
>> PSGST        A39,A39+5,A39+8,A39+9,TIMES+1,TIMES+4,TIMES+5,DOSE+2,DOSE+3
>> PSJSYSP      A8+3
   TMPFD        A10+1~,A10+13*!
   TMPX         A10+9~*
   U            DOSE+2
   X            A39+1*,A39+2*,A39+3,A39+4,A39+5,A39+6*,A39+7*,A39+8,A39+9
                A39+10,A39+12,A10+4*,A10+5,A10+6,A10+7*,A10+8,A10+9*,A25+3*
                A25+4*,A25+5,A25+6*,A25+7,A25+10,A25+12,A25+13,A25+15,A255+1~
                A255+4,TIMES+1!,TIMES+4!,TIMES+8!,TIMES+9!,TIMES+10
                DOSE+1~
   X1           A10+9*,A25+11*,A25+15*,A255+1~,A255+2*
   X2           A10+9*,A25+11*,A25+15*,A255+1~,A255+2*,A255+3
>> Y            A39+3,A10+8,A10+9,A10+10,A10+11,A25+5,A25+8,A25+11,A255+4,FF+1*
   Z            W25+1~,W25+2,DOSE+2*,DOSE+5*

Global Variables  ( * Changed  ! Killed)
   ^PS(51.1            TIMES+3
   ^PS(53.45           A8+3
   ^TMP("CLOZFLG"      A25+10,A255

Naked Globals
   NONE

Cache Objects
   NONE

Marked Items
   NONE

Label References
   @(           A39+3,A10+8,A25+5,DONE+3
   A10          A10+6,A10+8,A10+9,A10+10
   A25          A25+5,A25+7,A25+8,A25+10,A255+3,W25+2
   A39          A39+3,A39+4,A39+5,A39+7,A39+8,A39+10
   DEL          A39+7
   DONE         A39,A39+1,A39+9,A39+12,A8+2,A8+4,A10+4,A10+5,A10+6,A10+14,A25+3
   DOSE         W25+2
   TIMES        A39+8

External References
   ^%DT                A10+9,A25+8
   ^%DTC               A25+11
   C^%DTC              A10+9,A25+15,A255+4
   EN^DDIOL            W25+5,TIMES+1,TIMES+4,TIMES+8,TIMES+9,TIMES+10
   YN^DICN             DEL+1
   $$ENDL^PSGDL        A25+7
   ENE^PSGDL           A25+7
   ENPREV^PSGDL        A10+6
   $$ENDD^PSGMI        A10+6,A10+11,A10+13,A25+8,A25+16,A255+4
   $$ENDTC^PSGMI       A10+6,A10+11,A10+13,A25+8,A255+4
   ENFF^PSGOE82        A39+3,A10+8,A25+5
   ENFF^PSGOEM         FF+1
   ENHLP^PSGOEM        A39+4,A39+6,A10+7,A10+9,A25+6
   $$ODD^PSGS0         A39,A39+8
   $$PRNOK^PSGS0       A39,A39+8,TIMES+1
   ENCHK^PSGS0         A39+10
   $$DIFFSI^PSJBCMA5   A8+2
   $$EDITSI^PSJBCMA5   A8+2
   $$DURMIN^PSJLIVMD   A10+12
   $$GETDUR^PSJLIVMD   A10+12
   $$LASTREN^PSJLMPRI  A10+2
   $$ENQ^PSJORP2       DOSE+5
   $$ENBCMA^PSJUTL     A8+4
   EFDNV^PSJUTL        DONE+2
   PAUSE^VALM1         A10+3
   $$FMADD^XLFDT       A10+13

*****   END   *****


PSGOE82  * *  118 Lines,  5497 Bytes, Checksum: B25952597
                                                  Jul 01, 2016@13:24:55 page 9
              852 bytes in comments
PSGOE82  ;BIR/CML3-NON-VERIFIED ORDER EDIT (CONT.) ;27 Jan 98 / 9:32 AM
         ;;5.0;INPATIENT MEDICATIONS ;**2,35,50,67,58,81,127,168,181,276,327**;1
          6 DEC 97;Build 10
         ;
         ; Reference to ^DD(53.1 is supported by DBIA #2256.
         ; Reference to ^VA(200 is supported by DBIA #10060.
         ; Reference to ^DIE is supported by DBIA #10018.
         ; Reference to ^DIC is supported by DBIA #10006.
         ; Reference to ^DICN is supported by DBIA #10009.
         ;
1        ; provider
         S MSG=0,PSGF2=1 S:PSGOEEF(PSGF2) BACK="1^PSGOE82"
A1       I $G(PSGORD)["P",$G(PSGP) I $$LASTREN^PSJLMPRI(PSGP,PSGORD) D  Q
         . W !?5,"This order has been renewed. Provider may not be edited at thi
          s point. " D PAUSE^VALM1
         S PSTMPI=PSGPR,PSTMPN=PSGPRN
         W !,"PROVIDER: ",$S(PSGPR:PSGPRN_"// ",1:"") R X:DTIME I X="^"!'$T W:'$
          T $C(7) S PSGOEE=0 G DONE
         I $S(X="":'PSGPR,1:X="@") W $C(7),"  (Required)" S X="?" D ENHLP^PSGOEM
          (53.1,1) G A1
         I X="",PSGPR S X=PSGPRN I PSGPR'=PSGPRN,$D(^VA(200,PSGPR,"PS")) W:0 "  
            "_$P(^("PS"),"^",2)_"    "_$P(^("PS"),"^",3) G:'$G(ANQX) DONE
         I +$G(ANQX) G A2
         I X?1."?" D ENHLP^PSGOEM(53.1,1)
         I $E(X)="^" D ENFF G:Y>0 @Y G A1
         K DIC S DIC="^VA(200,",DIC(0)="EMQZ",DIC("S")="I $D(^(""PS"")),^(""PS""
          ),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)>DT)" D ^DIC K DI
          C I Y'>0 G A1
         ;; START NCC T4 MODS >> 327*RJS
         S PSGPR=+Y,PSGPRN=Y(0,0)
A2       D CLOZPRV
         I $G(ANQX) S PSGPR=PSTMPI,PSGPRN=PSTMPN  K PSTMPN,PSTMPI G A1
         ;; END NCC T4 MODS << 327*RJS
         G DONE
         ;
5        ; self med
         S MSG=0,PSGF2=5 S:PSGOEEF(PSGF2) BACK="5^PSGOE82" K PSGOEEF(6) S:PSGSM 
          PSGOEEF(6)=1
A5       W !,"SELF MED: " W $P("NO^YES","^",PSGSM+1),"// " R X:DTIME I X="^"!'$T
           W:'$T $C(7) S PSGOEE=0 G DONE
         ;I "01"[X,$L(X)<2 S:PSGSM=""&(X]"") PSGSM=X W:PSGSM]"" "  (",$P("NO^YES
          ","^",PSGSM+1),")" G:'PSGSM DONE S PSGOEEF(6)=1 G 6
         I "01"[X,$L(X)<2 S:X]"" PSGSM=+X W:PSGSM]"" "  (",$P("NO^YES","^",PSGSM
          +1),")" G:'PSGSM DONE S PSGOEEF(6)=1 G 6
         I X="@" W $C(7),"  (Required)" G A5
         I X?1"^".E D ENFF G:Y>0 @Y G A5
         I X?1."?" D ENHLP^PSGOEM(53.1,5) G A5
         D YN I  S PSGSM=$E(X)="Y" K PSGOEEF(6) G:'PSGSM DONE S PSGOEEF(6)=1 G 6
         W $C(7) D ENHLP^PSGOEM(53.1,5) G A5
         ;
6        ; hospital supplied self med
         S MSG=0,PSGF2=6 S:PSGOEEF(PSGF2) BACK="6^PSGOE82"
A6       W !,"HOSPITAL SUPPLIED SELF MED: " W:PSGHSM]"" $P("NO^YES","^",PSGHSM+1
          ),"// " R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
         I "01"[X,$L(X)=1 S:X]"" PSGHSM=+X W "  (",$P("NO^YES","^",PSGHSM+1),")"
           S MSG=0,PSGF2=5 G DONE
         I X="@" W $C(7),"  (Required)" G A6
         I X?1"^".E D ENFF G:Y>0 @Y G A6
         I X?1."?" D ENHLP^PSGOEM(53.1,6) G A6
         D YN I  S PSGHSM=$E(X)="Y" S MSG=0,PSGF2=5 G DONE
         W $C(7) D ENHLP^PSGOEM(53.1,6) G A6
         ;
2        ; dispense drug multiple
         ;*276 - Disallow unauthorized nurses from editing Dispense Drug
         I '$P($G(PSJSYSU),";",4) W !,"You are not authorized to edit Dispense D
          rugs." D PAUSE^VALM1 Q
         S MSG=0,PSGF2=2,BACK="2^PSGOE82" K PSGOEEND
         N PSGX,PSGXX F PSGXX=0:0 S PSGX=PSGXX,PSGXX=$O(^PS(53.45,PSJSYSP,2,PSGX
          X)) Q:'PSGXX
         N PSJPNDRN I $G(PSGORD) I $E(PSGORD,$L(PSGORD))="P",$P($G(^PS(53.1,+PSG
          ORD,0)),"^",24)="R" S PSJPNDRN=1 D
         .S $P(PSJPNDRN,"^",2)="Dispense drugs for renewal orders cannot be dele
          ted, but can be given an INACTIVE DATE.  "
         N DA,DIC,DIE,DR,DIR S DIE="^PS(53.45,",DA=PSJSYSP,DR=2,DR(2,53.4502)=".
          01;.02"_$S($G(PSJPNDRN):";.03",1:"") D ^DIE
         I '$O(^PS(53.45,PSJSYSP,2,0)) W $C(7),!!,"WARNING: This order must have
           at least one dispense drug before pharmacy can",!?9,"verify it!",! S 
          MSG=1
         D DDOC(PSGX)
         NEW PSJDOSE
         D DOSECHK^PSJDOSE
         I +$G(PSJDSFLG) D DSPWARN^PSJDOSE S PSGOEEF(109)=1
         G DONE
         ;
40       ; comments
         S MSG=0,PSGF2=40,BACK="40^PSGOE82",DA=PSJSYSP,DR=1,DIE="^PS(53.45," D ^
          DIE W ! G DONE
         ;
66       ; provider comments
         ;S MSG=0,PSGF2=66,BACK="66^PSGOE82",DA=PSJSYSP,DR=4,DIE="^PS(53.45," D 
          ^DIE W ! G DONE
         ;
DONE     ;
         I PSGOEE G:'PSGOEEF(PSGF2) @BACK S PSGOEE=PSGOEEF(PSGF2)
         K F,F0,PSGF2,F3,PSG,SDT Q
         ;
ENFF     ; up-arrow to another field
         S Y=-1 I '$D(PSGOEEF)!(X?1"^"1.9N) W $C(7),"  ??" Q
         S X=$E(X,2,99) I X=+X S Y=$S($D(PSGOEEF(X)):X,1:-1) W "  " W:Y>0 $$CODE
          S2^PSIVUTL(53.1,X) W:Y'>0 $C(7),"??" Q
         K DIC S DIC="^DD(53.1,",DIC(0)="QEM",DIC("S")="I $D(PSGOEEF(+Y))" D ^DI
          C K DIC S Y=+Y S:Y>0 Y=$P($T(@("F"_Y)),";",3) Q
         ;
DEL      ; delete entry
         W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W $C(7),"  <NOTH
          ING DELETED>"
         Q
         ;
CLOZPRV  ;; START NCC T4 MODS >> 327*RJS
         I '$G(PSGDRG) S PSGDRG=$O(^PSDRUG("ASP",PSGPDRG,0)) I PSGDRG,'$O(^(PSGD
          RG)) Q
         I $D(^PSDRUG("ACLOZ",PSGDRG)) D
         .S ANQX=0 D PROVCHK^PSJCLOZ(PSGPR)
         .I ANQX=0 K PSTMPN,PSTMPI
         ;; END NCC T4 MODS << 327*RJS
         Q
         ;
YN       ; yes/no as a set of codes
         I X'?.U F Y=1:1:$L(X) I $E(X,Y)?1L S X=$E(X,1,Y-1)_$C($A(X,Y)-32)_$E(X,
          Y+1,$L(X))
         F Y="NO","YES" I $P(Y,X)="" W $P(Y,X,2) Q
         Q
DDOC(PSGX) --
          ; Order check on additional dispense drug for allergy and adv. reactio
n
          s.
         N PSGY,PSGND1,PSGND3,PSJALLGY
         S PSGY=0 F  S PSGX=$O(^PS(53.45,PSJSYSP,2,PSGX)) Q:'PSGX  S PSGY=$P($G(
          ^PS(53.45,PSJSYSP,2,PSGX,0)),"^") Q:PSGY=""  D
         . N INTERVEN,PSJDDI,PSJIREQ,PSJRXREQ,PSJDD,PSGORQF,PSJPDRG S PSJDD=PSGY
         . S Y=1,(PSJIREQ,PSJRXREQ,INTERVEN,X)=""
         . I '$G(PSJALGY1) S PSJALLGY(PSJDD)="" D ALLERGY^PSJOC
         . ;D IVSOL^PSGSICHK
         . I ($D(PSGORQF)) D
         .. K ^PS(53.45,PSJSYSP,2,PSGX),^PS(53.45,PSJSYSP,2,"B",PSGY)
         Q
         ;
F101     ;;101^PSGOE8
F109     ;;109^PSGOE8
F3       ;;3^PSGOE8
F7       ;;7^PSGOE8
PSGF26   ;;26^PSGOE8
F39      ;;39^PSGOE81
F8       ;;8^PSGOE81
F10      ;;10^PSGOE81
PSGF25   ;;25^PSGOE81
F1       ;;1^PSGOE82
F5       ;;5^PSGOE82
PSGF2    ;;2^PSGOE82

*****   INDEX OF PSGOE82   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
>> %            DEL+1*
>> ANQX         A1+5,A1+6,A2+1,CLOZPRV+3*,CLOZPRV+4
>> BACK         1+1*,5+1*,6+1*,2+3*,40+1*,DONE+1
   DA           2+7~*,40+1*
   DIC          A1+9!*,2+7~,ENFF+3!*
   DIC("S"      A1+9*,ENFF+3*
   DIC(0        A1+9*,ENFF+3*
   DIE          2+7~*,40+1*
   DIR          2+7~
   DR           2+7~*,40+1*
   DR(2         2+7*
   DTIME        A1+3,A5,A6
   F            DONE+2!
   F0           DONE+2!
   F3           DONE+2!
   INTERVEN     DDOC+3~,DDOC+4*
>> MSG          1+1*,5+1*,6+1*,A6+1*,A6+5*,2+3*,2+8*,40+1*
   PSG          DONE+2!
>> PSGDRG       CLOZPRV+1*,CLOZPRV+2
   PSGF2        1+1*,5+1*,6+1*,A6+1*,A6+5*,2+3*,40+1*,DONE+1,DONE+2!
>> PSGHSM       A6,A6+1*,A6+5*
   PSGND1       DDOC+1~
   PSGND3       DDOC+1~
>> PSGOEE       A1+3*,A5*,A6*,DONE+1*
>> PSGOEEF      ENFF+1
>> PSGOEEF(     1+1,5+1,6+1,DONE+1,ENFF+2
>> PSGOEEF(109  2+12*
>> PSGOEEF(6    5+1!*,A5+2*,A5+6!*
   PSGOEEND     2+3!
>> PSGORD       A1,2+5
   PSGORQF      DDOC+3~,DDOC+7
>> PSGP         A1
>> PSGPDRG      CLOZPRV+1
>> PSGPR        A1+2,A1+3,A1+4,A1+5,A1+11*,A2+1*,CLOZPRV+3
>> PSGPRN       A1+2,A1+3,A1+5,A1+11*,A2+1*
>> PSGSM        5+1,A5,A5+2*,A5+6*
   PSGX         2+4~*,2+9,DDOC~,DDOC+2*,DDOC+8
   PSGXX        2+4~*
   PSGY         DDOC+1~,DDOC+2*,DDOC+3,DDOC+8
>> PSJALGY1     DDOC+5
   PSJALLGY     DDOC+1~
   PSJALLGY(    DDOC+5*
   PSJDD        DDOC+3~*,DDOC+5
   PSJDDI       DDOC+3~
   PSJDOSE      2+10~
>> PSJDSFLG     2+12
   PSJIREQ      DDOC+3~,DDOC+4*
   PSJPDRG      DDOC+3~
   PSJPNDRN     2+5~*,2+6*,2+7
   PSJRXREQ     DDOC+3~,DDOC+4*
>> PSJSYSP      2+4,2+7,2+8,40+1,DDOC+2,DDOC+8
>> PSJSYSU      2+2
   PSTMPI       A1+2*,A2+1!,CLOZPRV+4!
   PSTMPN       A1+2*,A2+1!,CLOZPRV+4!
   SDT          DONE+2!
>> X            A1+3*,A1+4*,A1+5*,A1+7,A1+8,A5*,A5+2,A5+3,A5+4,A5+5,A5+6,A6*
                A6+1,A6+2,A6+3,A6+4,A6+5,ENFF+1,ENFF+2*,YN+1*,YN+2,DDOC+4*
>> Y            A1+8,A1+9,A1+11,A5+4,A6+3,ENFF+1*,ENFF+2*,ENFF+3*,YN+1*,YN+2*
                DDOC+4*
>> Y(0          A1+11

Global Variables  ( * Changed  ! Killed)
   ^PS(53.1            2+5
   ^PS(53.45           2+4,2+8,DDOC+2,DDOC+8!
   ^PSDRUG("ACLOZ"     CLOZPRV+2
   ^PSDRUG("ASP"       CLOZPRV+1
   ^VA(200             A1+5

Naked Globals
   ^(           CLOZPRV+1
   ^("PS"       A1+5

Cache Objects
   NONE

Marked Items
   $T(@(3)      ENFF+3

Label References
   6            A5+2,A5+6
   @(           A1+8,A5+4,A6+3,DONE+1
   A1           A1+4,A1+8,A1+9,A2+1
   A2           A1+6
   A5           A5+3,A5+4,A5+5,A5+7
   A6           A6+2,A6+3,A6+4,A6+6
   CLOZPRV      A2
   DDOC         2+9
   DONE         A1+3,A1+5,A2+3,A5,A5+2,A5+6,A6,A6+1,A6+5,2+13,40+1
   ENFF         A1+8,A5+4,A6+3
   YN           A5+6,A6+5

External References
   ^DIC                A1+9,ENFF+3
   YN^DICN             DEL+1
   ^DIE                2+7,40+1
   ENHLP^PSGOEM        A1+4,A1+7,A5+5,A5+7,A6+4,A6+6
   $$CODES2^PSIVUTL    ENFF+2
   PROVCHK^PSJCLOZ     CLOZPRV+3
   DOSECHK^PSJDOSE     2+11
   DSPWARN^PSJDOSE     2+12
   $$LASTREN^PSJLMPRI  A1
   ALLERGY^PSJOC       DDOC+5
   PAUSE^VALM1         A1+1,2+2

*****   END   *****


PSGOE92  * *  118 Lines,  6309 Bytes, Checksum: B33386592
                                                  Jul 01, 2016@13:24:55 page 10
              827 bytes in comments
PSGOE92  ;BIR/CML3 - ACTIVE ORDER EDIT (CONT.) ; 2/18/10 4:15pm
         ;;5.0;INPATIENT MEDICATIONS ;**2,35,50,58,81,110,215,237,276,316,327**;
          16 DEC 97;Build 10
         ;
         ;Reference to ^DD(53.1 is supported by DBIA #2256.
         ;Reference to ^PS(55 is supported by DBIA #2191.
         ;Reference to ^PSDRUG is supported by DBIA #2192.
         ;
1        ; provider
         S MSG=0,PSGF2=1 S:PSGOEEF(PSGF2) BACK="1^PSGOE92"
A1       I $G(PSJORD),$G(PSGP) I $$COMPLEX^PSJOE(PSGP,PSJORD) S PSGOEE=0 D  G DO
          NE
         . W !!?5,"Provider may not be edited for active complex orders." D PAUS
          E^VALM1
         W !,"PROVIDER: ",$S(PSGPR:PSGPRN_"// ",1:"") R X:DTIME I X="^"!'$T W:'$
          T $C(7) S PSGOEE=0 G DONE
         S PSTMPI=PSGPR,PSTMPN=PSGPRN
         I $S(X="":'PSGPR,1:X="@") W $C(7),"  (Required)" S X="?" D ENHLP^PSGOEM
          (55.06,1) G A1
         I X="",PSGPR S X=PSGPRN I PSGPR'=PSGPRN,$D(^VA(200,PSGPR,"PS")) W:0 "  
            "_$P(^("PS"),"^",2)_"    "_$P(^("PS"),"^",3) G DONE
         ;; START NCC T4 MODS >> 327*RJS
         I +$G(ANQX) G A2
         I X?1."?" D ENHLP^PSGOEM(55.06,1)
         I $E(X)="^" D ENFF G:Y>0 @Y G A1
         K DIC S DIC="^VA(200,",DIC(0)="EMQZ",DIC("S")="I $D(^(""PS"")),^(""PS""
          ),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)>DT)" D ^DIC K DI
          C I Y'>0 G A1
         S PSGPR=+Y,PSGPRN=Y(0,0)
A2       D CLOZPRV^PSGOE82
         I $G(ANQX) W ! S PSGPR=PSTMPI,PSGPRN=PSTMPN  K PSTMPN,PSTMPI G A1
         ;; END NCC T4 MODS << 327*RJS
         G DONE
         ;
5        ; self med
         I $G(PSJORD),$G(PSGP) I $$COMPLEX^PSJOE(PSGP,PSJORD) S PSGOEE=0 D  G DO
          NE
         . W !!?5,"Self Med may not be edited for active complex orders." D PAUS
          E^VALM1
         S MSG=0,PSGF2=5 S:PSGOEEF(PSGF2) BACK="5^PSGOE92" K PSGOEEF(6) S:PSGSM 
          PSGOEEF(6)=""
A5       W !,"SELF MED: " W:PSGSM]"" $P("NO^YES","^",PSGSM+1),"// " R X:DTIME I 
          X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
         I "01"[X,$L(X)<2 S:X]"" PSGSM=+X W:PSGSM]"" "  (",$P("NO^YES","^",PSGSM
          +1),")" G:'PSGSM DONE S PSGOEEF(6)="" G 6
         I X="@" W $C(7),"  (Required)" G A5
         I X?1"^".E D ENFF G:Y>0 @Y G A5
         I X?1."?" D ENHLP^PSGOEM(55.06,5) G A5
         D YN I  S PSGSM=$E(X)="Y" K PSGOEEF(6) G:'PSGSM DONE S PSGOEEF(6)="" G 
          6
         W $C(7) D ENHLP^PSGOEM(55.06,5) G A5
         ;
6        ; hospital supplied self med
         S MSG=0,PSGF2=6 S:PSGOEEF(PSGF2) BACK="6^PSGOE92"
A6       I $G(PSJORD),$G(PSGP) I $$COMPLEX^PSJOE(PSGP,PSJORD) S PSGOEE=0 D  G DO
          NE
         . W !!?5,"Hospital Supplied Self Med may not be edited for active compl
          ex orders." D PAUSE^VALM1
         W !,"HOSPITAL SUPPLIED SELF MED: " W:PSGHSM]"" $P("NO^YES","^",PSGHSM+1
          ),"// " R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOEE=0 G DONE
         I "01"[X,$L(X)=1 S:X]"" PSGHSM=+X W "  (",$P("NO^YES","^",PSGHSM+1),")"
           S MSG=0,PSGF2=5 G DONE
         I X="@" W $C(7),"  (Required)" G A6
         I X?1"^".E D ENFF G:Y>0 @Y G A6
         I X?1."?" D ENHLP^PSGOEM(55.06,6) G A6
         D YN I  S PSGHSM=$E(X)="Y" S MSG=0,PSGF2=5 G DONE
         W $C(7) D ENHLP^PSGOEM(55.06,6) G A6
         ;
2        ; dispense drug multiple
         ;*276 - Disallow unauthorized nurses from editing Dispense Drug
         I '$P($G(PSJSYSU),";",4) W !,"You are not authorized to edit Dispense D
          rugs." D PAUSE^VALM1 Q
         I $G(PSGP),$G(PSGORD) I $$COMPLEX^PSJOE(PSGP,PSGORD) D
         . N X,Y,PARENT,P2ND S P2ND=$S(PSGORD["U":$G(^PS(55,PSGP,5,+PSGORD,.2)),
          1:$G(^PS(53.1,+PSGORD,.2))),PARENT=$P(P2ND,"^",8)
         . I PARENT D FULL^VALM1 W !!?5,"This order is part of a complex order. 
          Please review the following ",!?5,"associated orders before changing t
          his order." D CMPLX^PSJCOM1(PSGP,PARENT,PSGORD)
         S MSG=0,PSGF2=2,BACK="2^PSGOE92",PSGOEEND=1
         NEW PSGX,PSGXX F PSGXX=0:0 S PSGX=PSGXX,PSGXX=$O(^PS(53.45,PSJSYSP,2,PS
          GXX)) Q:'PSGXX
         K PSGXX
         N DA,DIE,DR S DIE="^PS(53.45,",DA=PSJSYSP,DR=2,DR(2,53.4502)=".02//1;.0
          3" D ^DIE
         I '$O(^PS(53.45,PSJSYSP,2,0)) W $C(7),!!,"WARNING: This order must have
           at least one dispense drug before pharmacy can",!?9,"verify it!",! S 
          MSG=1
         D DDOC^PSGOE82(PSGX) ;* Perform allergy/adv. reaction order checks
         NEW PSJDOSE
         D DOSECHK^PSJDOSE
         I +$G(PSJDSFLG) D DSPWARN^PSJDOSE S:$G(PSGOEEF(109))="" PSGOEEF(109)=1 
          ; PSJ*5*237 - Check PSGOEEF(109) to prevent infinite loop
         ; PSJ*5*215 - If Dispense Drug(s) changed, make entry in Activity Log.
         ; Compare the edited dispense drug information in ^PS(53.45 to the acti
          ve
         ; order dispense drug information in ^PS(55.
         S (PSJDDTMP,PSJDD55,PSJDTMP1,PSJDD551)=""
         F PSJDDTMP=0:0 S PSJDDTMP=$O(^PS(53.45,PSJSYSP,2,PSJDDTMP)) Q:'PSJDDTMP
            D
         . S PSJDDTMP(PSJDDTMP)=$G(^PS(53.45,PSJSYSP,2,PSJDDTMP,0))
         . S PSJDTMP1="Disp Drug: "_"("_$P($G(PSJDDTMP(PSJDDTMP)),"^",1)_") "_$P
          ($G(^PSDRUG($P($G(PSJDDTMP(PSJDDTMP)),"^",1),0)),"^")_" Units: "_$P($G
          (PSJDDTMP(PSJDDTMP)),"^",2)_" "
         F PSJDD55=0:0 S PSJDD55=$O(^PS(55,DFN,5,+ON,1,PSJDD55)) Q:'PSJDD55  D
         . S PSJDD55(PSJDD55)=$G(^PS(55,DFN,5,+ON,1,PSJDD55,0))
         . S PSJDD551="Disp Drug: "_"("_$P($G(PSJDD55(PSJDD55)),"^",1)_") "_$P($
          G(^PSDRUG($P($G(PSJDD55(PSJDD55)),"^",1),0)),"^")_" Units: "_$P($G(PSJ
          DD55(PSJDD55)),"^",2)_" "
         ; If the two temporary strings PSJDTMP1 and PSJDD551 do not match each 
          other exactly
         ; then an edit has been made to the Dispense Drug Field.  Make a new en
          try in
         ; the Activity Log for this order.
         I PSJDTMP1'=PSJDD551 D NEWUDAL^PSGAL5(DFN,+ON,6000,"Dispense Drug",PSJD
          D551)
         K PSGOEEND,PSJDDTMP,PSJDTMP1,PSJDD55,PSJDD551 G DONE
         ;
15       ; comments
         I $G(PSJORD),$G(PSGP) I $$COMPLEX^PSJOE(PSGP,PSJORD) S PSGOEE=0 D  G DO
          NE
         . W !!?5,"Comments may not be edited for active complex orders." D PAUS
          E^VALM1
         S MSG=0,PSGF2=15,BACK="15^PSGOE92",DA=PSJSYSP,DR=1,DIE="^PS(53.45," D ^
          DIE W ! G DONE
         ;
72       ; provider comments
         ;
DONE     ;
         I PSGOEE G:'PSGOEEF(PSGF2) @BACK S PSGOEE=PSGOEEF(PSGF2)
         K F,F0,PSGF2,F3,PSG,SDT Q
         ;
ENFF     ; up-arrow to another field
         S Y=-1 I '$D(PSGOEEF) W $C(7),"  ??" Q
         S X=$E(X,2,99) I X=+X S Y=$S($D(PSGOEEF(X)):X,1:-1) W "  " W:Y>0 $$CODE
          S2^PSIVUTL(53.1,X) W:Y'>0 $C(7),"??" Q
         K DIC S DIC="^DD(53.1,",DIC(0)="QEM",DIC("S")="I $D(PSGOEEF(+Y))" D ^DI
          C K DIC S Y=+Y S:Y>0 Y=$P($T(@("F"_Y)),";",3) Q
         ;
DEL      ; delete entry
         W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W $C(7),"  <NOTH
          ING DELETED>"
         Q
         ;
YN       ; yes/no as a set of codes
         I X'?.U F Y=1:1:$L(X) I $E(X,Y)?1L S X=$E(X,1,Y-1)_$C($A(X,Y)-32)_$E(X,
          Y+1,$L(X))
         F Y="NO","YES" I $P(Y,X)="" W $P(Y,X,2) Q
         Q
         ;
F101     ;;101^PSGOE9
F109     ;;109^PSGOE9
F3       ;;3^PSGOE9
F7       ;;7^PSGOE9
PSGF26   ;;26^PSGOE9
F41      ;;41^PSGOE91
F8       ;;8^PSGOE91
F10      ;;10^PSGOE91
F34      ;;34^PSGOE91
F1       ;;1^PSGOE92
F5       ;;5^PSGOE92
PSGF2    ;;2^PSGOE92

*****   INDEX OF PSGOE92   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
>> %            DEL+1*
>> ANQX         A1+7,A2+1
>> BACK         1+1*,5+3*,6+1*,2+6*,15+3*,DONE+1
   DA           2+9~*,15+3*
>> DFN          2+22,2+23,2+28
   DIC          A1+10!*,ENFF+3!*
   DIC("S"      A1+10*,ENFF+3*
   DIC(0        A1+10*,ENFF+3*
   DIE          2+9~*,15+3*
   DR           2+9~*,15+3*
   DR(2         2+9*
   DTIME        A1+2,A5,A6+2
   F            DONE+2!
   F0           DONE+2!
   F3           DONE+2!
>> MSG          1+1*,5+3*,6+1*,A6+3*,A6+7*,2+6*,2+10*,15+3*
>> ON           2+22,2+23,2+28
   P2ND         2+4~*
   PARENT       2+4~*,2+5
   PSG          DONE+2!
   PSGF2        1+1*,5+3*,6+1*,A6+3*,A6+7*,2+6*,15+3*,DONE+1,DONE+2!
>> PSGHSM       A6+2,A6+3*,A6+7*
>> PSGOEE       A1*,A1+2*,5+1*,A5*,A6*,A6+2*,15+1*,DONE+1*
>> PSGOEEF      ENFF+1
>> PSGOEEF(     1+1,5+3,6+1,DONE+1,ENFF+2
>> PSGOEEF(109  2+14*
>> PSGOEEF(6    5+3!*,A5+1*,A5+5!*
   PSGOEEND     2+6*,2+29!
>> PSGORD       2+3,2+4,2+5
>> PSGP         A1,5+1,A6,2+3,2+4,2+5,15+1
>> PSGPR        A1+2,A1+3,A1+4,A1+5,A1+11*,A2+1*
>> PSGPRN       A1+2,A1+3,A1+5,A1+11*,A2+1*
>> PSGSM        5+3,A5,A5+1*,A5+5*
   PSGX         2+7~*,2+11
   PSGXX        2+7~*,2+8!
   PSJDD55      2+18*,2+22*,2+23,2+24,2+29!
   PSJDD55(     2+23*,2+24
   PSJDD551     2+18*,2+24*,2+28,2+29!
   PSJDDTMP     2+18*,2+19*,2+20,2+21,2+29!
   PSJDDTMP(    2+20*,2+21
   PSJDOSE      2+12~
>> PSJDSFLG     2+14
   PSJDTMP1     2+18*,2+21*,2+28,2+29!
>> PSJORD       A1,5+1,A6,15+1
>> PSJSYSP      2+7,2+9,2+10,2+19,2+20,15+3
>> PSJSYSU      2+2
   PSTMPI       A1+3*,A2+1!
   PSTMPN       A1+3*,A2+1!
   SDT          DONE+2!
   X            A1+2*,A1+4*,A1+5*,A1+8,A1+9,A5*,A5+1,A5+2,A5+3,A5+4,A5+5,A6+2*
                A6+3,A6+4,A6+5,A6+6,A6+7,2+4~,ENFF+2*,YN+1*,YN+2
   Y            A1+9,A1+10,A1+11,A5+3,A6+5,2+4~,ENFF+1*,ENFF+2*,ENFF+3*,YN+1*
                YN+2*
   Y(0          A1+11

Global Variables  ( * Changed  ! Killed)
   ^PS(53.1            2+4
   ^PS(53.45           2+7,2+10,2+19,2+20
   ^PS(55              2+4,2+22,2+23
   ^PSDRUG(            2+21,2+24
   ^VA(200             A1+5

Naked Globals
   ^("PS"       A1+5

Cache Objects
   NONE

Marked Items
   $T(@(3)      ENFF+3

Label References
   6            A5+1,A5+5
   @(           A1+9,A5+3,A6+5,DONE+1
   A1           A1+4,A1+9,A1+10,A2+1
   A2           A1+7
   A5           A5+2,A5+3,A5+4,A5+6
   A6           A6+4,A6+5,A6+6,A6+8
   DONE         A1,A1+2,A1+5,A2+3,5+1,A5,A5+1,A5+5,A6,A6+2,A6+3,A6+7,2+29,15+1
                15+3
   ENFF         A1+9,A5+3,A6+5
   YN           A5+5,A6+7

External References
   ^DIC                A1+10,ENFF+3
   YN^DICN             DEL+1
   ^DIE                2+9,15+3
   NEWUDAL^PSGAL5      2+28
   CLOZPRV^PSGOE82     A2
   DDOC^PSGOE82        2+11
   ENHLP^PSGOEM        A1+4,A1+8,A5+4,A5+6,A6+6,A6+8
   $$CODES2^PSIVUTL    ENFF+2
   CMPLX^PSJCOM1       2+5
   DOSECHK^PSJDOSE     2+13
   DSPWARN^PSJDOSE     2+14
   $$COMPLEX^PSJOE     A1,5+1,A6,2+3,15+1
   FULL^VALM1          2+5
   PAUSE^VALM1         A1+1,5+2,A6+1,2+2,15+2

*****   END   *****


PSGOEF   * *  222 Lines,  13061 Bytes, Checksum: B108959334
                                                  Jul 01, 2016@13:24:55 page 11
              1995 bytes in comments
PSGOEF   ;BIR/CML3 - FINISH ORDERS ENTERED THROUGH OE/RR ;14 May 98  2:17 PM
         ;;5.0;INPATIENT MEDICATIONS;**7,30,29,35,39,47,50,56,80,116,110,111,133
          ,153,134,222,113,181,260,199,281,327**;16 DEC 97;Build 10
         ;
         ; Reference to ^PS(55 is supported by DBIA 2191
         ; Reference to ^PSDRUG( is supported by DBIA 2192
         ; Reference to DOSE^PSSORPH is supported by DBIA 3234.
         ; Reference to ^TMP("PSODAOC",$J is supported by DBIA 6071.
         ; Reference to FULL^VALM1 is supported by DBIA 10116.
         ;
START    ;
         I '$D(^PS(53.1,+PSGORD)) W $C(7),!?3,"Cannot find this pending order (#
          ",+PSGORD,")." Q
         D NOW^%DTC S PSGDT=+$E(%,1,12) K PSGFDX,PSGEFN,PSGOEEF,PSGOES,PSGONF,PS
          GRDTX S PSGOES=1,(PSGOEF,PSGOEEF)=0,PSGOEEG=3
         I $D(PSJTUD) S PSGDO=$P($G(^PS(53.1,+PSGORD,.3)),U),(PSGPDRG,PSGPD)=PSJ
          COI,(PSGPDRGN,PSGPDN)=$$OINAME^PSJLMUTL(PSGPD)
         I $P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" S X=PSGSCH D EN^PSGORS0 D
         . S:($D(X)&($P($G(^PS(53.1,+PSGORD,2)),"^",5)="")&($P($G(^PS(53.1,+PSGO
          RD,0)),"^",24)="N")) PSGAT=PSGS0Y
         . NEW PSJDOX,PSJDOSE,PSJPIECE,PSJUNIT,PSJX,X
         . S X=$G(^PS(53.1,+PSGORD,1,1,0)) Q:'+X
         . D DOSE^PSSORPH(.PSJDOX,+X,"U")
         . I $S('$D(PSJDOX):1,1:+PSJDOX(1)=-1) Q
         . S PSJPIECE=$S($P(PSJDOX(1),U)="":3,1:1)
         . S X=^PS(53.1,+PSGORD,.2)
         . S:PSJPIECE=3 PSJDOSE=$P(X,U,2)
         . S:PSJPIECE=1 PSJDOSE=$P(X,U,5),PSJUNIT=$P(X,U,6)
         . F X=0:0 S X=$O(PSJDOX(X)) Q:+$G(PSJX)!'X  D
         .. I PSJPIECE=3,($P(PSJDOX(X),U,3)'=PSJDOSE) Q
         .. I PSJPIECE=1,($P(PSJDOX(X),U,1)_$P(PSJDOX(X),U,2)'=(PSJDOSE_PSJUNIT)
          ) Q
         .. S:+$P(PSJDOX(X),U,12) $P(^PS(53.45,PSJSYSP,2,1,0),U,2)=+$P(PSJDOX(X)
          ,U,12),PSJX=1
         I PSGEB'=PSGOPR F X=7,11 S Y=$T(@(3_X)),@("PSGEFN("_X_")="_$P(Y,";",7))
          ,PSGOEEF(+$P(Y,";",3))="",PSGOEEF=PSGOEEF+1
         D GTST^PSGOE6(+PSGORD)
         I $P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" S PSGSD="" D:PSGS0Y]""
         .N PSJX S PSJX=$P($G(^PS(53.1,+PSGORD,0)),U,25) I PSJX="" Q
         .I PSJX["U" S PSGSD=$P($G(^PS(55,DFN,5,+PSJX,2)),U,2) Q
         .I PSJX["V" S PSGSD=$P($G(^PS(55,DFN,"IV",+PSJX,0)),U,2) Q
         .I PSJX["P" S PSGSD=$P($G(^PS(53.1,+PSJX,2)),U,2)
         S:PSGSD="" PSGSD=PSGLI
         S PSGNEDFD=$$GTNEDFD^PSGOE7("U",+PSGPD)
         S:$P($G(PSGNEDFD),U,3)="" $P(PSGNEDFD,U,3)=PSGST  ; N PSGOEA S PSGOEA="
          R"
         S (PSGNESD,PSGSD)=$$ENSD^PSGNE3(PSGSCH,PSGS0Y,PSGLI,PSGSD)
         ;if this is a renewal order, ignore any 'requested start date' received
          .  Use the system calculated start date.
         I $P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" D
         . D REQDT^PSJLIVMD(PSGORD)
         E  D
         . S X=$$DSTART^PSJDCU(DFN,$P(^PS(53.1,+PSGORD,0),U,25)) I X]"" S (PSGNE
          SD,PSGSD)=X K PSGRSD
         D   ; Extend the Default Stop Date if needed for the first renewed orde
          r.
         .N PSGOEAO,PSGWALLO
         .I $P($G(^PS(53.1,+PSGORD,0)),U,24)="R" S PSGOEAO=PSGOEA,PSGOEA="R",PSG
          WALLO=$P(^PS(55,DFN,5.1),U)
         .D ENFD^PSGNE3(PSGLI) S PSGFD=$S($G(PSGRDTX(+PSGORD,"PSGFD")):PSGRDTX(+
          PSGORD,"PSGFD"),1:PSGNEFD)
         .I $P($G(^PS(53.1,+PSGORD,0)),U,24)="R" S PSGOEA=PSGOEAO,$P(^PS(55,DFN,
          5.1),U)=PSGWALLO
         N DUR,PSGRNSD S PSGRNSD=+$$LASTREN^PSJLMPRI(DFN,PSGORD) I PSGRNSD S DUR
          =$$GETDUR^PSJLIVMD(DFN,PSGORD,"P",1) I DUR]"" D
         . N DURMIN S DURMIN=$$DURMIN^PSJLIVMD(DUR) I DURMIN S PSGFD=$$FMADD^XLF
          DT(PSGRNSD,,,DURMIN)
         S PSGOFD="",PSGSDN=$$ENDD^PSGMI(PSGSD)_U_$$ENDTC^PSGMI(PSGSD),PSGFDN=$$
          ENDD^PSGMI(PSGFD)_U_$$ENDTC^PSGMI(PSGFD)
         S PSGLIN=$$ENDD^PSGMI(PSGLI)_U_$$ENDTC^PSGMI(PSGLI)
         I '$O(^PS(53.45,PSJSYSP,2,0)) N DRG,DRGCNT S DRGCNT=0 D
         .F X=0:0 S X=$O(^PSDRUG("ASP",+PSGPD,X)) Q:'X!(DRGCNT>1)  S:$P($G(^PSDR
          UG(+X,2)),U,3)["U" DRGCNT=DRGCNT+1,DRG=+X
         .I DRGCNT=1 K ^PS(53.45,PSJSYSP,2) S ^PS(53.45,PSJSYSP,2,1,0)=DRG_U_1,^
          PS(53.45,PSJSYSP,2,0)="^53.4502^1^1",PS(53.45,PSJSYSP,2,"B",+DRG,1)=""
         Q
FINISH   ;
         ; force display of second screen if CPRS order checks exist
         N NSFF,PSGOEF39,PSGEDTOI S NSFF=1 K PSJNSS,PSGEDTOI,PSGOEER,ZZND
         I $G(PSGORD),$D(PSGRDTX(+PSGORD)) D  K PSGRDTX
         . ;PSJOCDSC stores the default start & stop date ^ cal start & stop dat
          e (use in dosing calculation for duration)
         . ;for some reasons PSGSD & PSGFD are reset to the cal dates if order h
          as duration defined
         . S PSJOCDSC("CX","PSGSD",+PSGORD)=$G(PSGSD)_U_$G(PSGRDTX(+PSGORD,"PSGR
          SD"))
         . S PSJOCDSC("CX","PSGFD",+PSGORD)=$G(PSGFD)_U_$G(PSGRDTX(+PSGORD,"PSGR
          FD"))
         . S:$G(PSGRDTX(+PSGORD,"PSGRSD")) PSGSD=PSGRDTX(+PSGORD,"PSGRSD")
         . S:$G(PSGRDTX(+PSGORD,"PSGRFD")) PSGFD=$S($G(PSGRDTX(+PSGORD,"PSGRFD")
          ):PSGRDTX(+PSGORD,"PSGRFD"),1:$G(PSGNEFD))
         N PSJCOM S PSJCOM=+$P($G(^PS(53.1,+PSGORD,.2)),"^",8)
         ; 
         ; PSJ*5*222
         ; PSJCT1 is a counter variable.  Every piece of a complex order calls P
          SGOEF.
         ; The only time this code is to look for overlapping admin times is whe
          n the
         ; first part of a complex order is being finished.  This variable will 
          keep track
         ; of how many "parts" of the complex order have been checked.
         ; 
         ; Also, since the user can select multiple complex orders to finish, li
          ke selecting
         ; orders 1-2 or 1-3 from the profile, PSJCT1A will keep track of whethe
          r the parent
         ; order number is the same as the first parent order number selected fo
          r finishing.
         ; Since the PSJCT1 counter variable will still be set if multiple compl
          ex orders
         ; are selected, PSJCT1 will be re-set to 1 if the parent complex order 
          number (PSJCT1A) is
         ; not equal to the original parent order number (PSJCOM).
         ; 
         S PSJCT1=$G(PSJCT1)+1
         I PSJCT1=1 S PSJCT1A=PSJCOM
         I $G(PSJCT1A)'=PSJCOM S PSJCT1=1,PSJCT1A=PSJCOM
         ; End of flag setting for PSJ*5*222
         ;PRE UAT group requested to not show the second screen since FDB OC has
           more text and provider override reason appears after 2nd screen 
         ;I $O(^PS(53.1,+PSGORD,12,0))!$O(^PS(53.1,+PSGORD,10,0)) D
         ;.Q:$G(PSJLMX)=1  ; there's no second screen to display
         ;.S VALMBG=16 D RE^VALM4,PAUSE^VALM1
         D FULL^VALM1
         ;; START NCC REMEDIATION >> 327*RJS
         I '$G(PSGDRG) S PSGDRG=$O(^PSDRUG("ASP",PSGPD,0)) I PSGDRG,'$O(^(PSGDRG
          )) Q
         I PSGSTAT'="ACTIVE",PSGSTAT'="NON-VERIFIED",PSGSTAT'="DISCONTINUED"  D
         .S ANQX=0 I $D(^PSDRUG("ACLOZ",PSGDRG)) D CLOZ^PSJCLOZ(PSGP,PSGDRG)
         I $G(ANQX) K DIR S DIR(0)="E" D ^DIR K DIR Q
         ;; END NCC REMEDIATION << 327*RJS
         I '$D(IOINORM)!('$D(IOINHI)) S X="IORVOFF;IORVON;IOINHI;IOINORM" D ENDR
          ^%ZISS
         I $G(PSJCOM)'="",$G(PSJCT1)=1 D
         . D OVERLAP^PSGOEF2 I $G(PSJOVRLP)=1 D
         . . N X,X1,DIR
         . . W !!,"**WARNING**"
         . . W !,"The highlighted admin times for these portions of this complex
           order overlap.",!!
         . . S (X,X1)="" F  S X=$O(^TMP("PSJATOVR",$J,X)) Q:X=""  D
         . . . S X1=$G(^TMP("PSJATOVR",$J,X))
         . . . W $S($P(X1,"^",4)=1:IORVON,1:""),"Part "_X,IORVOFF," has a schedu
          le of "_$P(X1,"^",2)_" and admin time(s) of "
         . . . W $S($P(X1,"^",4)=1:IORVON,1:""),$P(X1,"^",3),IORVOFF
         . . . W !
         . . . W $S($G(PSJOVR("CONJ",X))="A":"AND",$G(PSJOVR("CONJ",X))="T":"THE
          N",1:""),!
         . . W !,"Please ensure the schedules and administration times are appro
          priate.",!
         . . S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W !
         K ^TMP("PSJATOVR",$J)
         I $G(PSJPROT)=3,'$D(PSJTUD),'$$ENIVUD^PSGOEF1(PSGORD) Q
         I $G(PSGOSCH)]"" D  S:$G(PSGS0XT)'="" $P(^PS(53.1,+PSGORD,2),"^",6)=PSG
          S0XT
         .N PSGOES,PSGS0Y,PSGSCH S X=PSGOSCH K:$G(PSJTUD) NSFF D ENOS^PSGS0
         .I '($G(PSGORD)["P"&($P($G(^PS(53.1,+PSGORD,0)),"^",24)="R")) I $G(X)]"
          "&$G(PSGS0Y) S:$G(PSGAT)="" PSGAT=PSGS0Y
         .I $G(PSJNSS) S PSGOSCH="" K PSJNSS
         .I $G(PSGORD)["P",$G(PSGAT),$G(PSGS0Y),($G(PSGOSCH)]"") I PSGAT'=PSGS0Y
           D
         ..S PSGNSTAT=1 W $C(7),!!,"PLEASE NOTE:  This order's admin times (",PS
          GAT,")"
         ..W !?13," do not match the ward times (",PSGS0Y,")"
         ..W !?13," for this administration schedule (",PSGOSCH,")",!
         ..S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR K DIR  W 
          !
         I $G(PSGS0XT)="" S $P(^PS(53.1,+PSGORD,2),"^",6)=$S($P($G(ZZND),"^",3)'
          ="":$P(ZZND,"^",3),1:"")
         S CHK=0 S:$P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" PSGSI=$$ENPC^PSJUTL("U"
          ,+PSJSYSP,180,PSGSI)
         I '$G(PSJTUD),$G(PSJNSS),($G(PSGOSCH)]"") D NSSCONT^PSGS0(PSGOSCH,PSGS0
          XT) K PSJNSS S PSGOSCH=""
         S PSGOEFF=PSGOSCH=""+('$O(^PS(53.45,PSJSYSP,2,0))*10)
         I PSGOEFF S X=$S(PSGOEFF#2:" a SCHEDULE",1:"")_$S(PSGOEFF=11:" and",1:"
          ")_$S(PSGOEFF>9:" at least one DISPENSE DRUG",1:"")
         I 'PSGOEFF I (($G(PSGS0XT)="D")&($G(PSGAT)="")) S X=" Admin Times",PSGO
          EFF=1,PSGOEF39=1
         I PSGOEFF,X]"" S X=X_" before it can be finished."
         I PSGOEFF S CHK=1 W $C(7),!!,"PLEASE NOTE: This order must have" F Q=1:
          1:$L(X," ") S Y=$P(X," ",Q) W:$L(Y)+$X>78 ! W Y," "
         I $G(PSGOEF39) S PSGOEE=0,PSGOEFF=0 D  I 'PSGOEE D REFRESH^VALM G DONE
         .S F1=53.1,MSG=0,Y=$T(39),@("PSGFN(39)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";"
          ,3))=1,(PSGOEEF,PSGOEE)=1 W ! D @$P($T(39),";",3) S CHK=0
         I PSGOEFF=1 S F1=53.1,MSG=0,Y=$T(38),@("PSGFN(38)="_$P(Y,";",7)),PSGOEE
          F(+$P(Y,";",3))=1,(PSGOEE,PSGOEEF)=1 W ! D @$P($T(38),";",3) S CHK=0 G
          :'PSGOEE DONE
         I PSGOEFF=11 S F1=53.1,MSG=0,Y=$T(32),@("PSGFN(32)="_$P(Y,";",7)),PSGOE
          EF(+$P(Y,";",3))=1,(PSGOEE,PSGOEEF)=1 W ! D @$P($T(32),";",3) D  G:'PS
          GOEE DONE
         .S F1=53.1,MSG=0,Y=$T(38),@("PSGFN(38)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";"
          ,3))=1,(PSGOEE,PSGOEEF)=1 W ! D @$P($T(38),";",3) S CHK=0
         I PSGOEFF>9 S CHK=7 D ENDRG^PSGOEF1(+PSGPD,0) I CHK D ABORTACC Q
         I 'PSGOEFF D OC531^PSGOESF ; check every dispense drug from CPRS
         S VALMBG=1
         I 'PSGOEFF&($D(PSGORQF)) D RE^VALM4 Q
         I $G(MSG) K DIR S DIR(0)="E" W !! D ^DIR
         I PSGOEFF D:PSGST="" GTST^PSGOE6(+PSGORD)
         S PSJLMFIN=1
         K PSJACEPT I $O(^PS(53.1,+PSGORD,12,0)) S PSJLMP2=1
         S PSGOEENO=0,PSGSTAT=$S($P(PSJSYSP0,U,9):"ACTIVE",1:"NON-VERIFIED")
         NEW PSJDOSE,PSJDOX,PSJDSFLG
         D DOSECHK^PSJDOSE
         S:+$G(PSJDSFLG) VALMSG="Dosage Ordered & Dispense Drug are not compatib
          le"
         I PSGODO=PSGDO S PSGOEEF(109)=""
         I PSGODO'=PSGDO S PSGOEENO=1,VALMSG="This change will cause a new order
           to be created  "
         D EN^VALM("PSJU LM ACCEPT")
         I $G(PSJNSS) D  S PSGOEEF(26)="" K PSJACEPT,PSJNSS
         .K DIR S DIR(0)="FOA",DIR("A")="Invalid Schedule" D ^DIR K DIR
         I $G(PSGS0XT)="D",'$G(PSGS0Y),'$G(PSGAT),((",P,R,")'[(","_$G(PSGST)_","
          )) D  S PSGOEEF(39)="" K PSJACEPT
         .K DIR S DIR(0)="FOA",DIR("A")="   WARNING - Admin times are required f
          or DAY OF WEEK schedules  " D ^DIR K DIR
         ;***PSJ*5*113
         I $G(PSGAT)="",(PSGST="C"!(PSGST="R")) D
         .I $G(PSGS0XT) Q:$$ODD^PSGS0(PSGS0XT)
         .Q:$$PRNOK^PSGS0($G(PSGSCH))
         .Q:($P($G(ZZND),"^",5)'="C")
         .K PSJACEPT
         .K DIR S DIR(0)="FOA",DIR("A")="  WARNING - Admin times are required fo
          r CONTINUOUS orders " D ^DIR K DIR
         ;***
         I '$G(PSJACEPT) D ABORTACC Q
         I $G(PSJRNF),$G(^PS(53.1,+PSGORD,4)) D
         . W $C(7),!!,"ACCEPTING THIS ORDER WILL CHANGE THE STATUS TO ACTIVE."
         . S DIR(0)="Y",DIR("A")="Do you wish to make this order Active",DIR("?"
          ,1)="Enter ""N"" if you wish to exit without Activating this order,"
         . S DIR("?")="or ""Y"" to continue with the Activation process." D ^DIR
           S:'Y Y=-1 K DIR
         I $G(PSJRNF),$G(Y)=-1 S PSJACEPT=0 D ABORTACC Q
         I $G(PSJRNF),$G(Y)=1 S PSGOEAV=1
         I $G(PSGEDTOI) D OC^PSJOE1
         I $S($G(PSGORQF):0,$G(PSGEDTOI):0,$G(PSGOEER)["109^PSGOE8":1,$G(PSGOEER
          )["3^PSGOE8":1,$G(PSGOEER)["26^PSGOE8":1,$G(PSGOEER)["10^PSGOE81":1,$G
          (PSGOEER)["25^PSGOE81":1,1:0) D
         . NEW PSJDD S PSJDD=+$$DD53P45^PSJMISC()
         . D:$G(PSJDD) IN^PSJOCDS($G(PSGORD),"UD",PSJDD)
         I $G(PSGORQF) S PSGOEENO=0,PSJACEPT=0
         I PSGOEENO S PSJNOO=$$ENNOO^PSJUTL5("E"),PSJACEPT=$S(PSJNOO<0:0,1:1)
ACCEPT   ;
         N PSGUDFIN S PSGUDFIN=1
         S VALMBCK=$S($G(PSJACEPT):"Q",1:"R")
         I '$G(PSJACEPT) D ABORTACC Q
         K PSGOES,PSGRSD,PSGRSDN D:PSGOEENO NEW3^PSGOEE D:'PSGOEENO UPD^PSGOEF1 
          I $D(PSGOEF)!PSGOEENO S PSGCANFL=-1
         ;saves drug allergy signs/symptoms PSJ*5*260
         I $D(^TMP("PSODAOC",$J,"ALLERGY")) D
         .N DA,OCCDT,ORN,ORL,Z,RET,PSJDAOC
         .S PSJDAOC="IP "_$S($G(PSGORD)["P":"Pending/Non-Verified",$G(PSGORD)["U
          ":"Unit Dose",$G(PSGORD)["V":"IV",1:"")_" Allergy",OCCDT=$$NOW^XLFDT
         .I PSGORD["P" S ORN=$P(^PS(53.1,+PSGORD,0),U,21)
         .I PSGORD["U" S ORN=$P(^PS(55,DFN,5,+PSGORD,0),U,21)
         .I PSGORD["V" S ORN=$P(^PS(55,DFN,"IV",+PSGORD,0),U,21)
         .Q:'$G(ORN)
         . S PSJAGYSV=1 ;use in ^PSJOE to store allergy (also clean up this var)
         .;D SETOC^PSJNEWOC(PSGORD) ;set order checks in 100.05
         .;K ^TMP("PSODAOC",$J),^TMP("PSJDAOC",$J)
         D DONE1^PSGOEE
         D DONE
         Q
BYPASS   ;
         S PSGCANFL=1
         ;
DONE     ;
         K CHK,DA,DIE,DR,DRG,MSG,Q1,Q2,PSGNSTAT,PSGEDTOI,PSGOEER,ZZND
         K PSJOVR
         Q
ABORTACC ; Abort Accept process.
         K PSJCT1,PSJOVR,PSJOVRLP,PSJCT1A K ^TMP("PSODAOC",$J)
         D ABORT^PSGOEE K PSGOEEF D GETUD^PSJLMGUD(PSGP,PSGORD),^PSGOEF,ENSFE^PS
          GOEE0(PSGP,PSGORD),INIT^PSJLMUDE(PSGP,PSGORD) S VALMBCK="R",PSGSD=PSGN
          ESD,PSGFD=PSGNEFD Q
         ;
         ;
31       ;;101^PSGOE8;PSGOPD;PSGPD;101;1
32       ;;109^PSGOE8;PSGODO;PSGDO;109;PSGODO]""
33       ;;10^PSGOE81;PSGOSD;PSGSD;10;0
34       ;;3^PSGOE8;PSGOMR;PSGMR;3;1
35       ;;25^PSGOE81;PSGOFD;PSGFD;25;0
36       ;;7^PSGOE8;PSGOST;PSGST;7;0
37       ;;5^PSGOE82;PSGOSM;PSGSM;5;0
38       ;;26^PSGOE8;PSGOSCH;PSGSCH;26;1      
39       ;;39^PSGOE81;PSGOAT;PSGAT;39;0
310      ;;1^PSGOE82;PSGOPR;PSGPR;1;1
311      ;;8^PSGOE81;PSGOSI;PSGSI;8;0
312      ;;2^PSGOE82;;;2;0
313      ;;40^PSGOE82;;;40;0
         ;
AH       ;
         W !!?2,"Answer 'YES' to accept this order as a NON-VERIFIED UNIT DOSE o
          rder.  Answer",!,"'NO' to edit this order now.  Enter '^' to BYPASS th
          is order, leaving it as",!,"a PENDING INPATIENT order."
         Q

*****   INDEX OF PSGOEF   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
>> %            START+2
>> ANQX         FINISH+37*,FINISH+38
   CHK          FINISH+66*,FINISH+72*,FINISH+74*,FINISH+75*,FINISH+77*
                FINISH+78*,DONE+1!
   DA           ACCEPT+7~,DONE+1!
>> DFN          START+22,START+23,START+33,START+36,START+38,START+39,ACCEPT+10
                ACCEPT+11
   DIE          DONE+1!
   DIR          FINISH+38!,FINISH+43~,FINISH+64!,FINISH+82!,FINISH+94!
                FINISH+96!,FINISH+103!,FINISH+109!
   DIR("?"      FINISH+108*,FINISH+109*
   DIR("A"      FINISH+53*,FINISH+64*,FINISH+94*,FINISH+96*,FINISH+103*
                FINISH+108*
   DIR(0        FINISH+38*,FINISH+53*,FINISH+64*,FINISH+82*,FINISH+94*
                FINISH+96*,FINISH+103*,FINISH+108*
   DR           DONE+1!
   DRG          START+43~,START+44*,START+45,DONE+1!
   DRGCNT       START+43~*,START+44*,START+45
   DUR          START+39~*,START+40
   DURMIN       START+40~*
>> F1           FINISH+74*,FINISH+75*,FINISH+76*,FINISH+77*
>> IOINHI       FINISH+40
>> IOINORM      FINISH+40
>> IORVOFF      FINISH+48,FINISH+49
>> IORVON       FINISH+48,FINISH+49
   MSG          FINISH+74*,FINISH+75*,FINISH+76*,FINISH+77*,FINISH+82,DONE+1!
   NSFF         FINISH+2~*,FINISH+57!
   OCCDT        ACCEPT+7~,ACCEPT+8*
   ORL          ACCEPT+7~
   ORN          ACCEPT+7~,ACCEPT+9*,ACCEPT+10*,ACCEPT+11*,ACCEPT+12
>> PS(          START+45*
>> PSGAT        START+5*,FINISH+58*,FINISH+60,FINISH+61,FINISH+70,FINISH+95
                FINISH+98
>> PSGCANFL     ACCEPT+4*,BYPASS+1*
>> PSGDO        START+3*,FINISH+90,FINISH+91
>> PSGDRG       FINISH+35*,FINISH+37
>> PSGDT        START+2*
>> PSGEB        START+18
   PSGEDTOI     FINISH+2~!,FINISH+112,FINISH+113,DONE+1!
   PSGEFN       START+2!
>> PSGFD        START+37*,START+40*,START+41,FINISH+7,FINISH+9*,ABORTACC+2*
>> PSGFDN       START+41*
   PSGFDX       START+2!
>> PSGLI        START+25,START+28,START+37,START+42
>> PSGLIN       START+42*
>> PSGNEDFD     START+26*,START+27*
>> PSGNEFD      START+37,FINISH+9,ABORTACC+2
>> PSGNESD      START+28*,START+33*,ABORTACC+2
   PSGNSTAT     FINISH+61*,DONE+1!
>> PSGODO       FINISH+90,FINISH+91
>> PSGOEA       START+36*,START+38*
   PSGOEAO      START+35~,START+36*,START+38
>> PSGOEAV      FINISH+111*
>> PSGOEE       FINISH+73*,FINISH+74*,FINISH+75*,FINISH+76*,FINISH+77*
   PSGOEEF      START+2!*,START+18*,FINISH+74*,FINISH+75*,FINISH+76*,FINISH+77*
                ABORTACC+2!
   PSGOEEF(     START+18*,FINISH+74*,FINISH+75*,FINISH+76*,FINISH+77*
   PSGOEEF(109  FINISH+90*
   PSGOEEF(26   FINISH+93*
   PSGOEEF(39   FINISH+95*
>> PSGOEEG      START+2*
>> PSGOEENO     FINISH+86*,FINISH+91*,FINISH+116*,FINISH+117,ACCEPT+4
   PSGOEER      FINISH+2!,FINISH+113,DONE+1!
>> PSGOEF       START+2*,ACCEPT+4
   PSGOEF39     FINISH+2~,FINISH+70*,FINISH+73
>> PSGOEFF      FINISH+68*,FINISH+69,FINISH+70*,FINISH+71,FINISH+72,FINISH+73*
                FINISH+75,FINISH+76,FINISH+78,FINISH+79,FINISH+81,FINISH+83
   PSGOES       START+2!*,FINISH+57~,ACCEPT+4!
>> PSGOFD       START+41*
   PSGONF       START+2!
>> PSGOPR       START+18
>> PSGORD       START+1,START+3,START+4,START+5,START+7,START+11,START+19
                START+20,START+21,START+30,START+31,START+33,START+36,START+37
                START+38,START+39,FINISH+3,FINISH+6,FINISH+7,FINISH+8,FINISH+9
                FINISH+10,FINISH+55,FINISH+56,FINISH+58,FINISH+60
                FINISH+65,FINISH+66,FINISH+83,FINISH+85,FINISH+106,FINISH+115
                ACCEPT+8,ACCEPT+9,ACCEPT+10,ACCEPT+11,ABORTACC+2
>> PSGORQF      FINISH+81,FINISH+113,FINISH+116
>> PSGOSCH      FINISH+56,FINISH+57,FINISH+59*,FINISH+60,FINISH+63,FINISH+67*
                FINISH+68
>> PSGP         FINISH+37,ABORTACC+2
>> PSGPD        START+3*,START+26,START+44,FINISH+35,FINISH+78
>> PSGPDN       START+3*
>> PSGPDRG      START+3*
>> PSGPDRGN     START+3*
   PSGRDTX      START+2!,FINISH+3!
   PSGRDTX(     START+37,FINISH+3,FINISH+6,FINISH+7,FINISH+8,FINISH+9
   PSGRNSD      START+39~*,START+40
   PSGRSD       START+33!,ACCEPT+4!
   PSGRSDN      ACCEPT+4!
>> PSGS0XT      FINISH+56,FINISH+65,FINISH+67,FINISH+70,FINISH+95,FINISH+99
   PSGS0Y       START+5,START+20,START+28,FINISH+57~,FINISH+58,FINISH+60
                FINISH+62,FINISH+95
   PSGSCH       START+4,START+28,FINISH+57~,FINISH+100
>> PSGSD        START+20*,START+22*,START+23*,START+24*,START+25*,START+28*
                START+33*,START+41,FINISH+6,FINISH+8*,ABORTACC+2*
>> PSGSDN       START+41*
>> PSGSI        FINISH+66*
>> PSGST        START+27,FINISH+83,FINISH+95,FINISH+98
>> PSGSTAT      FINISH+36,FINISH+86*
   PSGUDFIN     ACCEPT+1~*
   PSGWALLO     START+35~,START+36*,START+38
   PSJACEPT     FINISH+85!,FINISH+93!,FINISH+95!,FINISH+102!,FINISH+105
                FINISH+110*,FINISH+116*,FINISH+117*,ACCEPT+2,ACCEPT+3
>> PSJAGYSV     ACCEPT+13*
>> PSJCOI       START+3
   PSJCOM       FINISH+10~*,FINISH+26,FINISH+27,FINISH+41
   PSJCT1       FINISH+25*,FINISH+26,FINISH+27*,FINISH+41,ABORTACC+1!
   PSJCT1A      FINISH+26*,FINISH+27*,ABORTACC+1!
   PSJDAOC      ACCEPT+7~,ACCEPT+8*
   PSJDD        FINISH+114~*,FINISH+115
   PSJDOSE      START+6~,START+12*,START+13*,START+15,START+16,FINISH+87~
   PSJDOX       START+6~,START+8,START+9,FINISH+87~
   PSJDOX(      START+14,START+15,START+16,START+17
   PSJDOX(1     START+9,START+10
   PSJDSFLG     FINISH+87~,FINISH+89
>> PSJLMFIN     FINISH+84*
>> PSJLMP2      FINISH+85*
>> PSJNOO       FINISH+117*
   PSJNSS       FINISH+2!,FINISH+59!,FINISH+67!,FINISH+93!
>> PSJOCDSC("CX" 
                FINISH+6*,FINISH+7*
   PSJOVR       DONE+2!,ABORTACC+1!
   PSJOVR("CONJ" 
                FINISH+51
   PSJOVRLP     FINISH+42,ABORTACC+1!
   PSJPIECE     START+6~,START+10*,START+12,START+13,START+15,START+16
>> PSJPROT      FINISH+55
>> PSJRNF       FINISH+106,FINISH+110,FINISH+111
>> PSJSYSP      START+17,START+43,START+45,FINISH+66,FINISH+68
>> PSJSYSP0     FINISH+86
>> PSJTUD       START+3,FINISH+55,FINISH+57,FINISH+67
   PSJUNIT      START+6~,START+13*,START+16
   PSJX         START+6~,START+14,START+17*,START+21~*,START+22,START+23
                START+24
>> Q            FINISH+72*
   Q1           DONE+1!
   Q2           DONE+1!
   RET          ACCEPT+7~
   U            START+3,START+4,START+10,START+12,START+13,START+15,START+16
                START+17,START+20,START+21,START+22,START+23,START+24,START+27
                START+30,START+33,START+36,START+38,START+41,START+42,START+44
                START+45,FINISH+6,FINISH+7,FINISH+66,FINISH+86
                ACCEPT+9,ACCEPT+10,ACCEPT+11
>> VALMBCK      ACCEPT+2*,ABORTACC+2*
>> VALMBG       FINISH+80*
>> VALMSG       FINISH+89*,FINISH+91*
   X            START+4*,START+5,START+6~,START+7*,START+8,START+11*,START+12
                START+13,START+14*,START+15,START+16,START+17,START+18*
                START+33*,START+44*,FINISH+40*,FINISH+43~,FINISH+46*,FINISH+47
                FINISH+48,FINISH+51,FINISH+57*,FINISH+58,FINISH+69*
                FINISH+70*,FINISH+71*,FINISH+72
   X1           FINISH+43~,FINISH+46*,FINISH+47*,FINISH+48,FINISH+49
>> Y            START+18*,FINISH+72*,FINISH+74*,FINISH+75*,FINISH+76*
                FINISH+77*,FINISH+109*,FINISH+110,FINISH+111
   Z            ACCEPT+7~
   ZZND         FINISH+2!,FINISH+65,FINISH+101,DONE+1!

Global Variables  ( * Changed  ! Killed)
   ^PS(53.1            START+1,START+3,START+4,START+5,START+7,START+11
                       START+20,START+21,START+24,START+30,START+33,START+36
                       START+38,FINISH+10,FINISH+56*,FINISH+58,FINISH+65*
                       FINISH+66,FINISH+85,FINISH+106,ACCEPT+9
   ^PS(53.45           START+17*,START+43,START+45!*,FINISH+68
   ^PS(55              START+22,START+23,START+36,START+38*,ACCEPT+10,ACCEPT+11
   ^PSDRUG(            START+44
   ^PSDRUG("ACLOZ"     FINISH+37
   ^PSDRUG("ASP"       START+44,FINISH+35
   ^TMP("PSJATOVR"     FINISH+46,FINISH+47,FINISH+54!
   ^TMP("PSODAOC"      ACCEPT+6,ABORTACC+1!

Naked Globals
   ^(           FINISH+35

Cache Objects
   NONE

Marked Items
   $T(32        FINISH+76
   $T(38        FINISH+75,FINISH+77
   $T(39        FINISH+74
   $T(@(3)      START+18

Label References
   32           FINISH+76
   38           FINISH+75,FINISH+77
   39           FINISH+74
   @(           FINISH+74,FINISH+75,FINISH+76,FINISH+77
   ABORTACC     FINISH+78,FINISH+105,FINISH+110,ACCEPT+3
   DONE         FINISH+73,FINISH+75,FINISH+76,ACCEPT+17

External References
   NOW^%DTC            START+2
   ENDR^%ZISS          FINISH+40
   ^DIR                FINISH+38,FINISH+53,FINISH+64,FINISH+82,FINISH+94
                       FINISH+96,FINISH+103,FINISH+109
   $$ENDD^PSGMI        START+41,START+42
   $$ENDTC^PSGMI       START+41,START+42
   $$ENSD^PSGNE3       START+28
   ENFD^PSGNE3         START+37
   GTST^PSGOE6         START+19,FINISH+83
   $$GTNEDFD^PSGOE7    START+26
   ABORT^PSGOEE        ABORTACC+2
   DONE1^PSGOEE        ACCEPT+16
   NEW3^PSGOEE         ACCEPT+4
   ENSFE^PSGOEE0       ABORTACC+2
   ^PSGOEF             ABORTACC+2
   $$ENIVUD^PSGOEF1    FINISH+55
   ENDRG^PSGOEF1       FINISH+78
   UPD^PSGOEF1         ACCEPT+4
   OVERLAP^PSGOEF2     FINISH+42
   OC531^PSGOESF       FINISH+79
   EN^PSGORS0          START+4
   $$ODD^PSGS0         FINISH+99
   $$PRNOK^PSGS0       FINISH+100
   ENOS^PSGS0          FINISH+57
   NSSCONT^PSGS0       FINISH+67
   CLOZ^PSJCLOZ        FINISH+37
   $$DSTART^PSJDCU     START+33
   DOSECHK^PSJDOSE     FINISH+88
   $$DURMIN^PSJLIVMD   START+40
   $$GETDUR^PSJLIVMD   START+39
   REQDT^PSJLIVMD      START+31
   GETUD^PSJLMGUD      ABORTACC+2
   $$LASTREN^PSJLMPRI  START+39
   INIT^PSJLMUDE       ABORTACC+2
   $$OINAME^PSJLMUTL   START+3
   $$DD53P45^PSJMISC   FINISH+114
   IN^PSJOCDS          FINISH+115
   OC^PSJOE1           FINISH+112
   $$ENPC^PSJUTL       FINISH+66
   $$ENNOO^PSJUTL5     FINISH+117
   DOSE^PSSORPH        START+8
   EN^VALM             FINISH+92
   REFRESH^VALM        FINISH+73
   FULL^VALM1          FINISH+33
   RE^VALM4            FINISH+81
   $$FMADD^XLFDT       START+40
   $$NOW^XLFDT         ACCEPT+8

*****   END   *****


PSGOER   * *  178 Lines,  11350 Bytes, Checksum: B91310828
                                                  Jul 01, 2016@13:24:55 page 12
              1292 bytes in comments
PSGOER   ;BIR/CML3 - RENEW A SINGLE ORDER ;4/27/11 9:54am
         ;;5.0;INPATIENT MEDICATIONS ;**11,30,29,35,70,58,95,110,111,133,141,198
          ,181,246,278,281,327**;16 DEC 97;Build 10
         ;
         ; Reference to ^PS(51.1 supported by DBIA 2177.
         ; Reference to ^PS(55 supported by DBIA 2191.
         ; Reference to ^PSSLOCK is supported by DBIA 2789.
         ; Reference to ^PSBAPIPM is supported by DBIA 3564.
         ; Reference to ^PS(59.7 is supported by DBIA 2181.
         ; Reference to ^PSDRUG( is supported by DBIA 2192.
         ; Reference to ^TMP("PSODAOC",$J is supported by DBIA 6071.
         ;
         ; renew a single order
         ;/RBN Begin modifications for PSJ*5.0*327
         I $D(^PSDRUG("ACLOZ",PSGDRG)) D  Q
         . W !!,"Clozapine orders cannot be renewed",!
         . D PAUSE^VALM1
         ;/RBN End modifications for PSJ*5.0*327
         I $G(PSJCOM) D ^PSJCOMR Q
         N PSJEXPIR S PSJEXPIR=$$EXPIRED(PSGP,PSGORD) I PSJEXPIR D  Q
         .W !!?3,"  THIS ORDER" W:PSJEXPIR'=2 " HAS BEEN INACTIVE FOR ONE OR MOR
          E SCHEDULED",!?8," ADMINISTRATIONS AND"
         .W " CANNOT BE RENEWED!" D PAUSE^VALM1
         I $G(PSGSCH)]"",($G(PSGS0XT)="D"),($G(PSGAT)="") D  Q
         .N SWD,SDW,XABB,X,QX S X=$G(PSGSCH) D DW^PSGS0 Q:($G(X)="")  I $G(PSGS0
          XT)="" S PSGS0XT="D"
         .Q:((",P,R,")[(","_$G(PSGST)_","))
         .I $G(PSGS0XT)="D",$G(PSGAT)="" S CHK=1 W !!?3,"This order contains a '
          DAY OF THE WEEK' schedule without admin times"
         .W !?11," and CANNOT be renewed!" D PAUSE^VALM1
         I $G(PSGSCH)]"",'$$DOW^PSIVUTL(PSGSCH),'$$PRNOK^PSGS0(PSGSCH) I '$D(^PS
          (51.1,"AC","PSJ",PSGSCH)) D  Q
         .W !!?3,"This order contains an invalid schedule and CANNOT be renewed!
          " D PAUSE^VALM1
         W !! K DIR S DIR(0)="Y",DIR("A")=$S($P(PSJSYSP0,"^",3):"RENEW THIS ORDE
          R",1:"MARK THIS ORDER FOR RENEWAL"),DIR("B")="YES"
         S DIR("?")="Answer 'YES' to "_$S($P(PSJSYSP0,"^",3):"renew this order",
          1:"mark this order for renewal")_".  Answer 'NO' (or '^') to stop now.
          " D ^DIR
         I '$D(DIRUT),Y D NEW S PSGCANFL=1 D DONE Q
         I '$D(DIRUT),PSJSYSU S PSGND4=$G(^PS(55,PSGP,5,+PSGORD,4)) I $P(PSGND4,
          "^",15),$P(PSGND4,"^",16) D UNMARK,DONE Q
         D DONE,ABORT^PSGOEE
         Q
         ;
UNMARK   ;  
         W !!,"THIS ORDER HAS BEEN 'MARKED FOR RENEWAL'.",! K DIR S DIR(0)="Y",D
          IR("A")="DO YOU WANT TO 'UNMARK IT'",DIR("B")="NO"
         S DIR("?",1)="  Answer 'YES' to unmark this order.  Answer 'NO' (or '^'
          ) to leave the order",DIR("?")="marked.  (An answer is required.)" D ^
          DIR
         I 'Y D ABORT^PSGOEE G DONE
         S DA(1)=PSGP,DA=+PSGORD,PSGAL("C")=21180+PSJSYSU D ^PSGAL5 S $P(PSGND4,
          "^",15,17)="^^",^PS(55,PSGP,5,DA,4)=PSGND4 W "...DONE!"
         ;
DONE     ;
         K %DT,DA,DIE,DIR,DR,FDSD,PSGAL,PSGALR,PSGDL,PSGDLS,PSGFD,PSGFOK,PSGND4,
          PSGOEE,PSGOER0,PSGOER1,PSGOER2,PSGOERDP,PSGPOSA,PSGPOSD,PSGPR,PSGPX,PS
          GRD,PSGSD,PSGTOL,PSGTOO,PSGUOW,PSGWLL,RF Q
         ;
NEW      ; get info, write record
EXTEND   ; extend stop date on renewal order
         N DUOUT,PSJABT,PSGDRG,PSJREN,PSGOREAS S PSGDRG=$P($G(^PS(55,PSGP,5,+PSG
          ORD,1,1,0)),"^"),PSJREN=1
         I $G(PSGST)="O" N ACT S ACT=$$EN^PSBAPIPM(PSGP,PSGORD) I $P(ACT,"^",2),
          ($P(ACT,"^",3)="G") I $P(ACT,"^",2)>$P($G(^PS(55,PSGP,5,+PSGORD,2)),"^
          ",2) D  Q
         . W !!?5,"THIS ONE-TIME ORDER HAS ALREADY BEEN GIVEN AND CANNOT BE RENE
          WED",! S (DIRUT,PSGORQF)=1 D READ
         ;D OC55
         ;Q:$D(PSGORQF)  ; quit if not to continue
         ;; START NCC T4 MODS >> 327*RJS
         I $D(^PSDRUG("ACLOZ",PSGDRG)) N PSGPR S PSGPR=PSGOPR D CLOZ^PSJCLOZ(DFN
          ,PSGDRG) S:$G(ANQX) PSGCANFL=1
         ;; START NCC T4 MODS >> 327*RJS
         D NOW^%DTC S PSGDT=%,PSGND4=$G(^PS(55,PSGP,5,+PSGORD,4)) I '$P(PSJSYSP0
          ,"^",3) D MARK Q
         S PSGWLL=$S('$P(PSJSYSW0,"^",4):0,1:+$G(^PS(55,PSGP,5.1))),PSGOEE="R" K
           PSGOEOS
         K ^PS(53.45,PSJSYSP,1),^(2) D MOVE(3,1),MOVE(1,2)
         D DATE^PSGOER0(PSGP,PSGORD,PSGDT) I ($G(X)="^")!'$D(PSGFOK(106))!$G(DUO
          UT) D DONE,ABORT^PSGOEE S VALMBCK="R",COMQUIT=1 Q
         ;D OC55
         ;I $G(PSGORQF) D DONE,ABORT^PSGOEE S VALMBCK="R",COMQUIT=1 Q
SPEED    ;
         I +$G(PSJSYSU)=3 D EN^PSGPEN(PSGORD)
         Q:$G(DUOUT)
         N PSGOEAV S PSGOEAV=+PSJSYSU
         W !!,"...updating order..." K DA S DA(1)=PSGP,DA=+PSGORD,PSGAL("C")=PSJ
          SYSU*10+18000 D ^PSGAL5 W "."
         I $$LS^PSSLOCK(PSGP,PSGORD) D UPDREN(PSGORD,PSGDT,PSGOEPR,PSGOFD,PSJNOO
          ),UPDRENOE(PSGP,PSGORD,PSGDT) D UNL^PSSLOCK(PSGP,PSGORD)
         S ^TMP("PSODAOC",$J,"IP IEN")=PSGORD   ;set up which IEN will be used t
          o store order checks
         D SETOC^PSJNEWOC(PSGORD) ;PSJ*5*281 stores order checks
         K ^TMP("PSODAOC",$J),^TMP("PSJDAOC",$J)
         ;
         I 'PSGOERDP,$P(PSJSYSW0,"^",4),PSGFD'<PSGWLL S $P(^PS(55,PSGP,5.1),"^")
          =+PSGFD
         W ".DONE!" S VALMBCK="Q" Q
         ;
MARK     ;
         I $P(PSGND4,"^",15),$P(PSGND4,"^",16) W $C(7),!!?3,"...THIS ORDER IS AL
          READY MARKED FOR RENEWAL!..." Q
         K DA S $P(PSGND4,"^",15,17)="1^"_DUZ_"^"_PSGDT,^PS(55,PSGP,5,+PSGORD,4)
          =PSGND4,PSGAL("C")=13180,DA(1)=PSGP,DA=+PSGORD W "." D ^PSGAL5
         I $D(PSJSYSO) S PSGORD=+PSGORD_"A",PSGPOSA="R",PSGPOSD=PSGDT D ENPOS^PS
          GVDS
         Q
MOVE(X,Y) ; Move comments/dispense drugs from 55 to 53.45.
         S Q=0 F  S Q=$O(^PS(55,PSGP,5,+PSGORD,X,Q)) Q:'Q  S ^PS(53.45,PSJSYSP,Y
          ,Q,0)=$G(^(Q,0))
         S:Q ^PS(53.45,Y,0)="^53.450"_Y_"P^"_Q_U_Q
         Q
OC55     ;* Order checks for Speed finish and regular finish
         ;PSJ*5*181 - no longer use (OC will be triggered from OC^PSGOER0)
         Q
NEWOC55  ;
         N INTERVEN,PSJDDI,PSJIREQ,PSJRXREQ,PSJPDRG,PSJDD,PSJDD0,PSJALLGY
         S Y=1,(PSJIREQ,PSJRXREQ,INTERVEN,X)=""
         F PSGDDI=0:0 S PSGDDI=$O(^PS(55,PSGP,5,+PSGORD,1,PSGDDI)) Q:'+PSGDDI  D
         . S PSJDD0=$G(^PS(55,PSGP,5,+PSGORD,1,PSGDDI,0))
         . S PSJX=$P(PSJDD0,U,3) I PSJX]"",(PSJX'>$G(PSGDT)) Q
         . S PSJDD=+PSJDD0
         . S PSJX=$S('$D(^PSDRUG(+PSJDD,0)):1,$P($G(^(2)),U,3)'["U":1,$G(^("I"))
          ="":0,1:^("I")'>$G(PSGDT))
         . Q:PSJX
         . S PSJALLGY(PSJDD)=""
         S PSJDD=$O(PSJALLGY(0))
         I '+PSJDD W !!,"No active dispense drug was found" D PAUSE^PSJLMUT1 Q
         K PSGORQF D ENDDC^PSGSICHK(PSGP,PSJDD)
         D:'$G(PSGORQF) IN^PSJOCDS(PSGORD,"UD",PSJDD) Q:$G(PSGORQF)
         Q
UPDREN(PSGORD,RNWDT,PSGOEPR,PSGOFD,PSJNOO,RDUZ) --
          ; update renewed order
         N DR,DA,DIC,DIE,DD,DO,PSGRZERO,PSGRFOUR,PSGOORD
         S DR="",PSGOEENO=0,PSGOORD=PSGORD,PSGNESD=PSGSD Q:'PSGORD!'RNWDT!'PSGOE
          PR!'PSGOFD  S PSJNOO=$S($G(PSJNOO)]"":$G(PSJNOO),1:"E")
         S PSGRZERO="^PS(55,"_PSGP_",5,"_+PSGORD_",0)",PSGOEORD=$P(@PSGRZERO,"^"
          ,21)
         ; PSJ*5*141 - changed PSGOEPR to PSGPR for field 1 of the DR string bel
          ow.
         S DA(1)=PSGP,DA=+PSGORD,DIE="^PS(55,"_PSGP_",5," S DR="34////^S X=PSGFD
          " S:$G(PSGPR) DR=DR_";1////"_PSGPR_";110////"_PSJNOO D ^DIE
         K DR,DA,DIC,DIE,DD,DO S DIC="^PS(55,"_PSGP_",5,"_+PSGORD_",14,",DIC(0)=
          "L",DIC("P")="55.6114DA",ND14=$G(@(DIC_"0)")),DINUM=$P(ND14,"^",3)+1,D
          A(2)=PSGP,DA(1)=+PSGORD D
         . S DIC("DR")=".01////"_$G(RNWDT)_";1////"_$S($G(RDUZ):RDUZ,1:$G(DUZ))_
          ";2////"_$G(PSGOEPR)_";3////"_$G(PSGOFD)_";4////"_+PSGOEORD,X=$G(RNWDT
          ) D FILE^DICN
         K DR,DA,DIC,DIE,DD,DO S DA(1)=PSGP,DA=+PSGORD,DIE="^PS(55,"_PSGP_",5,",
          DR="28////A;105////@;107////@"
         ;PSJ*5*198
         S PSGRFOUR="^PS(55,"_PSGP_",5,"_+PSGORD_",4)",PSGRFOUR=@PSGRFOUR I $P(P
          SGRFOUR,"^",2)<RNWDT S DR=DR_";16////@;17////@" I $G(PSJORD)["P",+PSJS
          YSU=1 S DR=DR_";18////@;19////@"
         I '$G(PSJSPEED) I $G(PSGAT)]"",$G(PSGAT)'=$P($G(@(DIE_+PSGORD_",2)")),"
          ^",5) S DR=DR_";41////"_PSGAT
         D ^DIE
         ; PSJ*5*278 - Check to re-assign orderable item
         N PSGPOI S PSGPOI=$$ACTIVE^PSJORREN(PSGP,PSGORD) Q:+PSGPOI=1  ;Quit if 
          no change to OI
         I +PSGPOI>1,$P(PSGPOI,U,2) D  ;replace OI
         . N DR,DA,DIE S DA(1)=PSGP,DA=+PSGORD,DIE="^PS(55,"_PSGP_",5,",DR="108/
          //^S X=$P(PSGPOI,U,2)" D ^DIE
         Q
UPDRENOE(PSGP,PSGORD,RDATE) --
          ;
         D EXPOE(PSGP,PSGORD,$G(RDATE)) ; expire original Orders File order
         I PSGORD'["P" K DA,DR,DIE S DA(1)=DFN,DA=+PSGORD,DIE="^PS(55,"_DFN_$S(P
          SGORD="U":",5,",1:",""IV"","),DR=$S(DIE["IV":110,1:66)_"////@" D ^DIE
         D ENUDTX^PSJOREN(PSGP,PSGORD,"NR")
         D EN1^PSJHL2(PSGP,"SN",PSGORD,"ORDER RENEWED")
         Q
READ     ; hold screen
         I $D(IOST) Q:$E(IOST)'="C"
         W !?5,"Press return to continue  " R X:$S($D(DTIME):DTIME,1:300)
         Q
EXPOE(DFN,PSJORDER,EXPDT) --
          ; expire old Orders File entry
         I PSJORDER["P" S FILE="^PS(53.1,"_+PSJORDER_",0)",PSJORDER=$P(@FILE,"^"
          ,25)
         I (PSJORDER'["U"),(PSJORDER'["V") Q
         N CURDAT D NOW^%DTC S CURDAT=$$DATE2^PSJUTL2(%)
         S PSJEXPOE=$S($G(EXPDT):EXPDT,1:CURDAT) D EN1^PSJHL2(DFN,"SC",PSJORDER)
           K PSJEXPOE
         Q
EXPIRED(PSJX,PSJY) --
          ;
         ; INPUT 
         ;       PSJX - Pharmacy Patient, pointer to ^PS(55
         ;       PSJY - Inpatient Order Number(appended with "V" or "U")
         ; OUTPUT
         ;   0  -  Order has not exceeded the Expired Time Limit 
         ;   1  -  Order has exceeded the Expired Time Limit
         N STOP,STATUS,NOW,CUTOFF,FREQ,LAST,ST,X,DFN,U,PSGDT,SD,WD,PSJPSTO,PSGDW
          ,PSGOC,ZZND,LASTAT,LSTSTR,PSBCNT S DFN=PSJX,U="^",CUTOFF=0
         S STATUS=$S(PSJY["U":$P($G(^PS(55,PSJX,5,+PSJY,0)),"^",9),PSJY["V":$P($
          G(^PS(55,PSJX,"IV",+PSJY,0)),"^",17),1:"")
         S NOW=$S($G(PSGDT):PSGDT,1:$$DATE^PSJUTL2())
         S STOP=$S(PSJY["U":$P($G(^PS(55,PSJX,5,+PSJY,2)),U,4),1:$P($G(^PS(55,PS
          JX,"IV",+PSJY,0)),"^",3))
         I NOW<STOP Q 0
         I PSJY["U" N ND2,ND0 S ND0=$G(^PS(55,PSJX,5,+PSJY,0)),ND2=$G(^PS(55,PSJ
          X,5,+PSJY,2)),FREQ=$P(ND2,"^",6) D
         .N SCHED S SCHED=$P($G(^PS(55,PSJX,5,+PSJY,2)),"^") I SCHED["PRN" S FRE
          Q=$$PRNFREQ(SCHED)
         .S LSTSTR=$P(ND2,"^",2)_"^"_$P(ND2,"^",4)_"^"_SCHED_"^"_$P(ND0,"^",7)_"
          ^^"_$P(ND2,"^",5)
         .S LAST=$$EN^PSBAPIPM(PSJX,PSJY) I LAST,($P(ND0,"^",7)="O"),($P(LAST,"^
          ",3)="G") I LAST>$P(ND2,"^",2) S CUTOFF=$$FMADD^XLFDT(NOW,,-1) Q
         .I 'LAST!(LAST>$P(ND2,"^",4)) S LAST=$$LASTAT^PSJORP2(DFN,LSTSTR) S:LAS
          T CUTOFF=$$FMADD^XLFDT(LAST,,,FREQ) Q
         .I SCHED["PRN",($P(LSTSTR,"^",6)="") S CUTOFF=$$FMADD^XLFDT(LAST,,,FREQ
          ) Q
         .I $$DOW^PSIVUTL(SCHED) S CUTOFF=$$NXTDOW(DFN,$P(LSTSTR,"^"),$P(LSTSTR,
          "^",2),$P(LSTSTR,"^",3),$P(LSTSTR,"^",6)) Q
         .S LAST=$$EN^PSBAPIPM(PSJX,PSJY) I 'LAST!(LAST>$P(ND2,"^",4)) S CUTOFF=
          $$FMADD^XLFDT(NOW,,-1) Q
         .S $P(LSTSTR,"^")=$$FMADD^XLFDT(LAST,,,,1),$P(LSTSTR,"^",2)=$$FMADD^XLF
          DT(PSGDT,,,FREQ) S CUTOFF=$$ENQ^PSJORP2(PSJX,LSTSTR)
         I PSJY["V" N LIMIT S LIMIT=$P($G(^PS(59.7,1,31)),"^",4) S LIMIT=$S((LIM
          IT]""):+LIMIT,1:24) S CUTOFF=$$FMADD^XLFDT(STOP,,LIMIT) D
         .I '($G(P(4))]"") N P,YP,XP S YP=$G(^PS(55,DFN,"IV",+PSJY,0)) F XP=1:1:
          23 S P(XP)=$P(YP,U,XP)
         .Q:'($G(P(4))]"")
         .Q:'$$SCHREQ^PSJLIVFD(.P)
         .N INTERVAL,LSTSTR,ND0,SCHED,IVSTYP S ND0=$G(^PS(55,PSJX,"IV",+PSJY,0))
          ,INTERVAL=$P(ND0,"^",15),SCHED=$P(ND0,"^",9) Q:SCHED=""
         .S IVSTYP=$S($$DOW^PSIVUTL(SCHED):"D",INTERVAL="O":"O",1:"C"),LSTSTR=$P
          (ND0,"^",2)_"^"_$P(ND0,"^",3)_"^"_SCHED_"^"_IVSTYP_"^^"_$P(ND0,"^",11)
         .S LAST=$$EN^PSBAPIPM(PSJX,PSJY) I LAST,IVSTYP="O",LAST>$P(ND0,"^",2),(
          $P(LAST,"^",3)="G") S CUTOFF=$$FMADD^XLFDT(NOW,,-1) Q
         .I 'LAST!(LAST>$P(ND0,"^",3))!(LAST&(IVSTYP="O")) S CUTOFF=$$FMADD^XLFD
          T(NOW,,-1) Q
         .I IVSTYP="D" S CUTOFF=$$NXTDOW(LAST,SCHED,$G(P(2)),$P($G(P(9)),"@"),$G
          (P(11))) Q
         .I SCHED["PRN" S FREQ=$$PRNFREQ(SCHED) S CUTOFF=$$FMADD^XLFDT(LAST,,,FR
          EQ) Q
         .S LAST=$$EN^PSBAPIPM(PSJX,PSJY) I 'LAST!(LAST>$P(ND0,"^",3)) S CUTOFF=
          $$FMADD^XLFDT(NOW,,-1) Q
         .S $P(LSTSTR,"^")=$$FMADD^XLFDT(LAST,,,,1),$P(LSTSTR,"^",2)=$$FMADD^XLF
          DT(PSGDT,31) S CUTOFF=$$ENQ^PSJORP2(PSJX,LSTSTR)
         K LYN,PSBDT,PSBFLAG,PSBSTR
         Q $S(CUTOFF<NOW:1,1:0)
         ;
NXTDOW(DOWDFN,DOWSD,DOWFD,DOWSCH,DOWAT) --
          ;
         N NXTADM,DOWSTR S DOWSTR=$$FMADD^XLFDT(DOWFD,,,,1)_"^"_$$FMADD^XLFDT(DO
          WFD,7)_"^"_DOWSCH_"^D^^"_DOWAT S NXTADM=$$ENQ^PSJORP2(DOWDFN,DOWSTR)
         Q $S(NXTADM:NXTADM,1:DOWSD)
         ;
PRNFREQ(SCHED) --
          ;
         N ZZND,D,DA,X,PSGAT,PSGOES,PSGST,PSJNSS,PSJPWD,TEST,VALMBCK,PSGS0XT,PSG
          S0Y,PSGDT
         F X=$P(SCHED,"PRN"),$P(SCHED,"PRN",2),$P(SCHED," PRN"),$P(SCHED,"PRN ",
          2) Q:$P($G(ZZND),"^",4)  D ADMIN^PSJORPOE
         Q $S($G(PSGS0XT):PSGS0XT,1:1440)

*****   INDEX OF PSGOER   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
>> %            EXTEND+9,EXPOE+3
   %DT          DONE+1!
   ACT          EXTEND+2~*
>> ANQX         EXTEND+7
>> CHK          PSGOER+24*
>> COMQUIT      EXTEND+12*
   CURDAT       EXPOE+3~*,EXPOE+4
   CUTOFF       EXPIRED+7~*,EXPIRED+15*,EXPIRED+16*,EXPIRED+17*,EXPIRED+18*
                EXPIRED+19*,EXPIRED+20*,EXPIRED+21*,EXPIRED+27*,EXPIRED+28*
                EXPIRED+29*,EXPIRED+30*,EXPIRED+31*,EXPIRED+32*,EXPIRED+34
   D            PRNFREQ+1~
   DA           UNMARK+4*,DONE+1!,SPEED+4!*,MARK+2!*,UPDREN+1~,UPDREN+5*
                UPDREN+6!,UPDREN+8!*,UPDREN+16~*,UPDRENOE+2!*,PRNFREQ+1~
   DA(1         UNMARK+4*,SPEED+4*,MARK+2*,UPDREN+5*,UPDREN+6*,UPDREN+8*
                UPDREN+16*,UPDRENOE+2*
   DA(2         UPDREN+6*
   DD           UPDREN+1~,UPDREN+6!,UPDREN+8!
   DFN          EXTEND+7,UPDRENOE+2,EXPOE~,EXPOE+4,EXPIRED+7~*,EXPIRED+16
                EXPIRED+18,EXPIRED+22
   DIC          UPDREN+1~,UPDREN+6!*,UPDREN+8!
   DIC("DR"     UPDREN+7*
   DIC("P"      UPDREN+6*
   DIC(0        UPDREN+6*
   DIE          DONE+1!,UPDREN+1~,UPDREN+5*,UPDREN+6!,UPDREN+8!*,UPDREN+11
                UPDREN+16~*,UPDRENOE+2!*
>> DINUM        UPDREN+6*
   DIR          PSGOER+28!,UNMARK+1!,DONE+1!
   DIR("?"      PSGOER+29*,UNMARK+2*
   DIR("A"      PSGOER+28*,UNMARK+1*
   DIR("B"      PSGOER+28*,UNMARK+1*
   DIR(0        PSGOER+28*,UNMARK+1*
>> DIRUT        PSGOER+30,PSGOER+31,EXTEND+3*
   DO           UPDREN+1~,UPDREN+6!,UPDREN+8!
   DOWAT        NXTDOW~,NXTDOW+1
   DOWDFN       NXTDOW~,NXTDOW+1
   DOWFD        NXTDOW~,NXTDOW+1
   DOWSCH       NXTDOW~,NXTDOW+1
   DOWSD        NXTDOW~,NXTDOW+2
   DOWSTR       NXTDOW+1~*
   DR           DONE+1!,UPDREN+1~,UPDREN+2*,UPDREN+5*,UPDREN+6!,UPDREN+8!*
                UPDREN+10*,UPDREN+11*,UPDREN+16~*,UPDRENOE+2!*
   DTIME        READ+2
   DUOUT        EXTEND+1~,EXTEND+12,SPEED+2
   DUZ          MARK+2,UPDREN+7
   EXPDT        EXPOE~,EXPOE+4
   FDSD         DONE+1!
>> FILE         EXPOE+1*
   FREQ         EXPIRED+7~,EXPIRED+12*,EXPIRED+13*,EXPIRED+16,EXPIRED+17
                EXPIRED+20,EXPIRED+30*
   INTERVAL     EXPIRED+25~*,EXPIRED+26
   INTERVEN     NEWOC55+1~,NEWOC55+2*
   IOST         READ+1
   IVSTYP       EXPIRED+25~,EXPIRED+26*,EXPIRED+27,EXPIRED+28,EXPIRED+29
   LAST         EXPIRED+7~,EXPIRED+15*,EXPIRED+16*,EXPIRED+17,EXPIRED+19*
                EXPIRED+20,EXPIRED+27*,EXPIRED+28,EXPIRED+29,EXPIRED+30
                EXPIRED+31*,EXPIRED+32
   LASTAT       EXPIRED+7~
   LIMIT        EXPIRED+21~*
   LSTSTR       EXPIRED+7~,EXPIRED+14*,EXPIRED+16,EXPIRED+17,EXPIRED+18
                EXPIRED+20*,EXPIRED+25~,EXPIRED+26*,EXPIRED+32*
   LYN          EXPIRED+33!
   ND0          EXPIRED+12~*,EXPIRED+14,EXPIRED+15,EXPIRED+25~*,EXPIRED+26
                EXPIRED+27,EXPIRED+28,EXPIRED+31
>> ND14         UPDREN+6*
   ND2          EXPIRED+12~*,EXPIRED+14,EXPIRED+15,EXPIRED+16,EXPIRED+19
   NOW          EXPIRED+7~,EXPIRED+9*,EXPIRED+11,EXPIRED+15,EXPIRED+19
                EXPIRED+27,EXPIRED+28,EXPIRED+31,EXPIRED+34
   NXTADM       NXTDOW+1~*,NXTDOW+2
   P            EXPIRED+22~,EXPIRED+24
   P(           EXPIRED+22*
   P(11         EXPIRED+29
   P(2          EXPIRED+29
   P(4          EXPIRED+22,EXPIRED+23
   P(9          EXPIRED+29
   PSBCNT       EXPIRED+7~
   PSBDT        EXPIRED+33!
   PSBFLAG      EXPIRED+33!
   PSBSTR       EXPIRED+33!
   PSGAL        DONE+1!
   PSGAL("C"    UNMARK+4*,SPEED+4*,MARK+2*
   PSGALR       DONE+1!
   PSGAT        PSGOER+21,PSGOER+24,UPDREN+11,PRNFREQ+1~
>> PSGCANFL     PSGOER+30*,EXTEND+7*
>> PSGDDI       NEWOC55+3*,NEWOC55+4
   PSGDL        DONE+1!
   PSGDLS       DONE+1!
   PSGDRG       PSGOER+13,EXTEND+1~*,EXTEND+7
   PSGDT        EXTEND+9*,EXTEND+12,SPEED+5,MARK+2,MARK+3,NEWOC55+5,NEWOC55+7
                EXPIRED+7~,EXPIRED+9,EXPIRED+20,EXPIRED+32,PRNFREQ+1~
   PSGDW        EXPIRED+7~
   PSGFD        DONE+1!,SPEED+10
   PSGFOK       DONE+1!
   PSGFOK(106   EXTEND+12
   PSGND4       PSGOER+31*,UNMARK+4*,DONE+1!,EXTEND+9*,MARK+1,MARK+2*
>> PSGNESD      UPDREN+2*
   PSGOC        EXPIRED+7~
   PSGOEAV      SPEED+3~*
   PSGOEE       DONE+1!,EXTEND+10*
>> PSGOEENO     UPDREN+2*
>> PSGOEORD     UPDREN+3*,UPDREN+7
   PSGOEOS      EXTEND+10!
   PSGOEPR      SPEED+5,UPDREN~,UPDREN+2,UPDREN+7
   PSGOER0      DONE+1!
   PSGOER1      DONE+1!
   PSGOER2      DONE+1!
   PSGOERDP     DONE+1!,SPEED+10
   PSGOES       PRNFREQ+1~
   PSGOFD       SPEED+5,UPDREN~,UPDREN+2,UPDREN+7
   PSGOORD      UPDREN+1~,UPDREN+2*
>> PSGOPR       EXTEND+7
   PSGORD       PSGOER+18,PSGOER+31,UNMARK+4,EXTEND+1,EXTEND+2,EXTEND+9
                EXTEND+12,SPEED+1,SPEED+4,SPEED+5,SPEED+6,SPEED+7,MARK+2
                MARK+3*,MOVE+1,NEWOC55+3,NEWOC55+4,NEWOC55+13,UPDREN~,UPDREN+2
                UPDREN+3,UPDREN+5,UPDREN+6,UPDREN+8,UPDREN+10,UPDREN+11
                UPDREN+14,UPDREN+16,UPDRENOE~,UPDRENOE+1,UPDRENOE+2,UPDRENOE+3
                UPDRENOE+4
   PSGOREAS     EXTEND+1~
   PSGORQF      EXTEND+3*,NEWOC55+12!,NEWOC55+13
   PSGP         PSGOER+18,PSGOER+31,UNMARK+4,EXTEND+1,EXTEND+2,EXTEND+9
                EXTEND+10,EXTEND+12,SPEED+4,SPEED+5,SPEED+10,MARK+2,MOVE+1
                NEWOC55+3,NEWOC55+4,NEWOC55+12,UPDREN+3,UPDREN+5,UPDREN+6
                UPDREN+8,UPDREN+10,UPDREN+14,UPDREN+16,UPDRENOE~,UPDRENOE+1
                UPDRENOE+3,UPDRENOE+4
   PSGPOI       UPDREN+14~*,UPDREN+15
   PSGPOSA      DONE+1!,MARK+3*
   PSGPOSD      DONE+1!,MARK+3*
   PSGPR        DONE+1!,EXTEND+7~*,UPDREN+5
   PSGPX        DONE+1!
   PSGRD        DONE+1!
   PSGRFOUR     UPDREN+1~,UPDREN+10*
   PSGRZERO     UPDREN+1~,UPDREN+3*
   PSGS0XT      PSGOER+21,PSGOER+22*,PSGOER+24,PRNFREQ+1~,PRNFREQ+3
   PSGS0Y       PRNFREQ+1~
>> PSGSCH       PSGOER+21,PSGOER+22,PSGOER+26
   PSGSD        DONE+1!,UPDREN+2
   PSGST        PSGOER+23,EXTEND+2,PRNFREQ+1~
   PSGTOL       DONE+1!
   PSGTOO       DONE+1!
   PSGUOW       DONE+1!
   PSGWLL       DONE+1!,EXTEND+10*,SPEED+10
   PSJABT       EXTEND+1~
   PSJALLGY     NEWOC55+1~
   PSJALLGY(    NEWOC55+9*
   PSJALLGY(0   NEWOC55+10
>> PSJCOM       PSGOER+17
   PSJDD        NEWOC55+1~,NEWOC55+6*,NEWOC55+7,NEWOC55+9,NEWOC55+10*
                NEWOC55+11,NEWOC55+12,NEWOC55+13
   PSJDD0       NEWOC55+1~,NEWOC55+4*,NEWOC55+5,NEWOC55+6
   PSJDDI       NEWOC55+1~
   PSJEXPIR     PSGOER+18~*,PSGOER+19
   PSJEXPOE     EXPOE+4*!
   PSJIREQ      NEWOC55+1~,NEWOC55+2*
   PSJNOO       SPEED+5,UPDREN~,UPDREN+2*,UPDREN+5
   PSJNSS       PRNFREQ+1~
>> PSJORD       UPDREN+10
   PSJORDER     EXPOE~,EXPOE+1*,EXPOE+2,EXPOE+4
   PSJPDRG      NEWOC55+1~
   PSJPSTO      EXPIRED+7~
   PSJPWD       PRNFREQ+1~
   PSJREN       EXTEND+1~*
   PSJRXREQ     NEWOC55+1~,NEWOC55+2*
>> PSJSPEED     UPDREN+11
>> PSJSYSO      MARK+3
>> PSJSYSP      EXTEND+11,MOVE+1
>> PSJSYSP0     PSGOER+28,PSGOER+29,EXTEND+9
>> PSJSYSU      PSGOER+31,UNMARK+4,SPEED+1,SPEED+3,SPEED+4,UPDREN+10
>> PSJSYSW0     EXTEND+10,SPEED+10
   PSJX         NEWOC55+5*,NEWOC55+7*,NEWOC55+8,EXPIRED~,EXPIRED+7,EXPIRED+8
                EXPIRED+10,EXPIRED+12,EXPIRED+13,EXPIRED+15,EXPIRED+19
                EXPIRED+20,EXPIRED+25,EXPIRED+27,EXPIRED+31,EXPIRED+32
   PSJY         EXPIRED~,EXPIRED+8,EXPIRED+10,EXPIRED+12,EXPIRED+13,EXPIRED+15
                EXPIRED+19,EXPIRED+21,EXPIRED+22,EXPIRED+25,EXPIRED+27
                EXPIRED+31
>> Q            MOVE+1*,MOVE+2
   QX           PSGOER+22~
   RDATE        UPDRENOE~,UPDRENOE+1
   RDUZ         UPDREN~,UPDREN+7
   RF           DONE+1!
   RNWDT        UPDREN~,UPDREN+2,UPDREN+7,UPDREN+10
   SCHED        EXPIRED+13~*,EXPIRED+14,EXPIRED+17,EXPIRED+18,EXPIRED+25~*
                EXPIRED+26,EXPIRED+29,EXPIRED+30,PRNFREQ~,PRNFREQ+2
   SD           EXPIRED+7~
   SDW          PSGOER+22~
   ST           EXPIRED+7~
   STATUS       EXPIRED+7~,EXPIRED+8*
   STOP         EXPIRED+7~,EXPIRED+10*,EXPIRED+11,EXPIRED+21
   SWD          PSGOER+22~
   TEST         PRNFREQ+1~
   U            MOVE+2,NEWOC55+5,NEWOC55+7,UPDREN+15,EXPIRED+7~*,EXPIRED+10
                EXPIRED+22
   VALMBCK      EXTEND+12*,SPEED+11*,PRNFREQ+1~
   WD           EXPIRED+7~
   X            PSGOER+22~*,EXTEND+12,MOVE~,MOVE+1,NEWOC55+2*,UPDREN+7*,READ+2*
                EXPIRED+7~,PRNFREQ+1~,PRNFREQ+2*
   XABB         PSGOER+22~
   XP           EXPIRED+22~*
   Y            PSGOER+30,UNMARK+3,MOVE~,MOVE+1,MOVE+2,NEWOC55+2*
   YP           EXPIRED+22~*
   ZZND         EXPIRED+7~,PRNFREQ+1~,PRNFREQ+2

Global Variables  ( * Changed  ! Killed)
   ^PS(51.1            PSGOER+26
   ^PS(53.45           EXTEND+11!,MOVE+1*,MOVE+2*
   ^PS(55              PSGOER+31,UNMARK+4*,EXTEND+1,EXTEND+2,EXTEND+9,EXTEND+10
                       SPEED+10*,MARK+2*,MOVE+1,NEWOC55+3,NEWOC55+4,EXPIRED+8
                       EXPIRED+10,EXPIRED+12,EXPIRED+13,EXPIRED+22,EXPIRED+25
   ^PS(59.7            EXPIRED+21
   ^PSDRUG(            NEWOC55+7
   ^PSDRUG("ACLOZ"     PSGOER+13,EXTEND+7
   ^TMP("PSJDAOC"      SPEED+8!
   ^TMP("PSODAOC"      SPEED+6*,SPEED+8!

Naked Globals
   ^(           MOVE+1
   ^("I"        NEWOC55+7
   ^(2          EXTEND+11!,NEWOC55+7

Cache Objects
   NONE

Marked Items
   NONE

Label References
   $$EXPIRED    PSGOER+18
   $$NXTDOW     EXPIRED+18,EXPIRED+29
   $$PRNFREQ    EXPIRED+13,EXPIRED+30
   DONE         PSGOER+30,PSGOER+31,PSGOER+32,UNMARK+3,EXTEND+12
   EXPOE        UPDRENOE+1
   MARK         EXTEND+9
   MOVE         EXTEND+11
   NEW          PSGOER+30
   READ         EXTEND+3
   UNMARK       PSGOER+31
   UPDREN       SPEED+5
   UPDRENOE     SPEED+5

External References
   NOW^%DTC            EXTEND+9,EXPOE+3
   FILE^DICN           UPDREN+7
   ^DIE                UPDREN+5,UPDREN+12,UPDREN+16,UPDRENOE+2
   ^DIR                PSGOER+29,UNMARK+2
   $$EN^PSBAPIPM       EXTEND+2,EXPIRED+15,EXPIRED+19,EXPIRED+27,EXPIRED+31
   ^PSGAL5             UNMARK+4,SPEED+4,MARK+2
   ABORT^PSGOEE        PSGOER+32,UNMARK+3,EXTEND+12
   DATE^PSGOER0        EXTEND+12
   EN^PSGPEN           SPEED+1
   $$PRNOK^PSGS0       PSGOER+26
   DW^PSGS0            PSGOER+22
   ENDDC^PSGSICHK      NEWOC55+12
   ENPOS^PSGVDS        MARK+3
   $$DOW^PSIVUTL       PSGOER+26,EXPIRED+18,EXPIRED+26
   CLOZ^PSJCLOZ        EXTEND+7
   ^PSJCOMR            PSGOER+17
   EN1^PSJHL2          UPDRENOE+4,EXPOE+4
   $$SCHREQ^PSJLIVFD   EXPIRED+24
   PAUSE^PSJLMUT1      NEWOC55+11
   SETOC^PSJNEWOC      SPEED+7
   IN^PSJOCDS          NEWOC55+13
   ENUDTX^PSJOREN      UPDRENOE+3
   $$ENQ^PSJORP2       EXPIRED+20,EXPIRED+32,NXTDOW+1
   $$LASTAT^PSJORP2    EXPIRED+16
   ADMIN^PSJORPOE      PRNFREQ+2
   $$ACTIVE^PSJORREN   UPDREN+14
   $$DATE^PSJUTL2      EXPIRED+9
   $$DATE2^PSJUTL2     EXPOE+3
   $$LS^PSSLOCK        SPEED+5
   UNL^PSSLOCK         SPEED+5
   PAUSE^VALM1         PSGOER+15,PSGOER+20,PSGOER+25,PSGOER+27
   $$FMADD^XLFDT       EXPIRED+15,EXPIRED+16,EXPIRED+17,EXPIRED+19,EXPIRED+20
                       EXPIRED+21,EXPIRED+27,EXPIRED+28,EXPIRED+30,EXPIRED+31
                       EXPIRED+32,NXTDOW+1

*****   END   *****


PSGOER0  * *  87 Lines,  5202 Bytes, Checksum: B24952711
                                                  Jul 01, 2016@13:24:55 page 13
              557 bytes in comments
PSGOER0  ;BIR/CML3 - EDIT FIELDS FOR RENEWAL ;12/09/07  02:22
         ;;5.0;INPATIENT MEDICATIONS;**11,45,47,50,63,64,70,69,58,80,110,127,136
          ,181,281,327**;16 DEC 97;Build 10
         ;
         ; Reference to ^PS(55 is supported by DBIA 2191. 
         ; Reference to ^VA(200 is supported by DBIA 10060.
         ; Reference to ^DD(55.06 is supported by DBIA 2253.
         ; Reference to ^%DT is supported by DBIA 10003.
         ; Reference to ^DIC is supported by DBIA 10006.
         ;
DATE(PSGP,PSGORD,PSGDT) --
          ;
         K PSGFOK,PSJNOO,PSGNEDFD,PSGOEPR,PSGOER0,PSGPDRG,PSGOER2,PSGWLL,PSGOERD
          P,PSGOFD,PSGPRN,PSGPRI,PSGOSD,PSGOPR,PSGRNSD,PSGS0XT,PSGS0Y,PSGST,PSGS
          CH,PSGSDN
         S F1=55.06,PSGWLL=+$G(^PS(55,PSGP,5.1)),PSGOER0=$G(^PS(55,PSGP,5,+PSGOR
          D,0)),PSGPDRG=+$G(^(.2)),PSGOER2=$G(^(2))
         NEW XX S XX=$$ACTIVE^PSJORREN(PSGP,PSGORD) S:+XX=2 PSGPDRG=$P(XX,U,2)
         I '+XX W !,"No active Orderable Item was found.",! G DONE
         S (PSGNEDFD,PSGOERDP)=$P($$GTNEDFD^PSGOE7("U",PSGPDRG),U)
         S PSGSCH=$P(PSGOER2,"^"),PSGST=$P(PSGOER0,"^",7),PSGS0Y=$P(PSGOER2,"^",
          5),PSGS0XT=$P(PSGOER2,"^",6)
         S PSGOEPR=+$P(PSGOER0,"^",2),(PSGOPR,PSGPR)=$S($P(PSJSYSU,";",2):DUZ,1:
          +PSGOEPR)
         I $G(PSJSPEED) S PSGPR=$S($P(ND,"^",2):$P(ND,"^",2),1:+PSGOEPR)
         S PSGOSD=+$P(PSGOER2,"^",2) S PSGOFD=+$P(PSGOER2,"^",4),PSGPRN=$P($G(^V
          A(200,PSGPR,0)),"^"),PSGPRI=$S($P(PSJSYSU,";",2):0,1:$P($G(^("PS")),"^
          ",4)),PSGRO=0 S:PSGPRI PSGPRI=PSGPRI'>DT I PSGPRI S (PSGOPR,PSGPR,PSGP
          RN)=""
         S PSGRNSD=$S($G(PSGLI):PSGLI,1:$G(PSGDT))
         S PSGSD=$G(PSGOSD)
         I PSGSD="" S PSJREN=1,PSGSD=$$ENSD^PSGNE3($S(PSGST["P":"PRN",1:$P(PSGOE
          R2,U)),PSGS0Y,PSGDT,PSGOSD) S:PSGOSD>PSGSD PSGSD=PSGOSD K PSJREN
         S PSGSDN=$$ENDD^PSGMI(PSGSD)
10       ;
         ;W !,"START DATE/TIME: "_PSGSDN
O25      ;
         N PSGSD,PSGNEFD S PSGSD=PSGDT
         D ENWALL^PSGNE3(PSGSD,0,PSGP)
         S:'$G(PSGDT) PSGDT=$$DATE2^PSJUTL2($$NOW^XLFDT)
         N PSGNESD S PSGNESD=PSGDT D ENFD^PSGNE3(PSGNESD) I $G(PSGNEFD) S (Y,PSG
          FD)=PSGNEFD
         S PSGFOK(10)="" I PSGST="O" S PSGFD=$$ENOSD^PSJDCU(PSJSYSW0,PSGRNSD,PSG
          P) I PSGFD]"" S Y=PSGRNSD,X=0 G 1
D25      K DUR,DURMIN N PKGFLG S PKGFLG=$S(PSGORD["U":5,PSGORD["V":"IV",PSGORD["
          P":"P",1:"") I PKGFLG]"" S DUR=$$GETDUR^PSJLIVMD(PSGP,+$G(PSGORD),PKGF
          LG,1) I DUR]"" D
         .S DURMIN=($$DURMIN^PSJLIVMD(DUR)\1) I DURMIN>1 S Y=$$FMADD^XLFDT(PSGRN
          SD,,,DURMIN) I Y>PSGRNSD S PSGFD=Y,X=0
         I $P($G(PSGOER2),"^",4)>PSGFD S Y=$P(PSGOER2,"^",4)
         I $G(DUR)]"",($G(PSGORD)'["P") S DURMIN=$$DURMIN^PSJLIVMD(DUR)\1 S Y=$$
          FMADD^XLFDT(PSGDT,,,DURMIN)
         S:X&$P(PSJSYSW0,"^",7) $P(Y,".",2)=$P(PSJSYSW0,"^",7) S PSGFD=+Y,PSGFDN
          =$$ENDD^PSGMI(PSGFD)
25       W !,"STOP DATE/TIME: "_PSGFDN_"// " R X:DTIME I X="^"!'$T W:'$T $C(7) S
          :'$T X="^" S PSGRO=1,COMQUIT=1 G DONE
         I X="" W "   "_PSGFDN G W25
         I $E(X)="^" D FF G:Y>0 @Y G 25
         S PSGF2=25 I X="@"!(X?1."?") W:X="@" $C(7),"  (Required)" S:X="@" X="?"
           D ENHLP^PSGOEM(55.06,25)
         I X=+X,X>0,X'>2000000 G 25:'$$ENDL^PSGDL(PSGSCH,X) K PSGDLS S PSGDL=X,N
          D2=PSGOER2,$P(ND2,"^",2)=PSGRNSD W " ...dose limit..." D ENGO^PSGDL
         K %DT S %DT="ERTX" D ^%DT K %DT G:Y'>0 25 S PSGFD=+Y,PSGFDN=$$ENDD^PSGM
          I(PSGFD)
W25      I PSGFD<PSGDT W $C(7),!!?13,"*** WARNING! THE STOP DATE ENTERED IS IN T
          HE PAST! ***",!
         I PSGFD<PSGSD W $C(7),!!?3,"*** The STOP date must be AFTER the START d
          ate. ***" G 25
         S PSGFOK(25)=""
         ;Display Expected First Dose;BHW;PSJ*5*136
         D EFDNEW^PSJUTL
         I $G(PSGONF),(+$G(PSGODDD(1))'<+$G(PSGONF)) S PSGFOK(1)="" Q
1        ; provider
         G:+PSJSYSU<3&$P(PSJSYSU,";",2) CHKDD S PSGF2=1
A1       ;
         S PSTMPI=PSGPR,PSTMPN=PSGPRN
         W !,"PROVIDER: ",$S(PSGPR:PSGPRN_"// ",1:"") R X:DTIME I X="^"!'$T W:'$
          T $C(7) S:'$T X="^" S PSGRO=1,COMQUIT=1 G DONE
         I $S(X="":'PSGPR,1:X="@") W $C(7),"  (Required)" S X="?" D ENHLP^PSGOEM
          (55.06,1) G A1
         I X="",PSGPR S X=PSGPRN I PSGPR'=PSGPRN,$D(^VA(200,PSGPR,"PS")) W "    
          "_$P(^("PS"),"^",2)_"    "_$P(^("PS"),"^",3) S PSGFOK(1)="" G:'$G(ANOX
          ) OC55
         I X?1."?" D ENHLP^PSGOEM(55.06,1)
         I $E(X)="^" D FF G:Y>0 @Y G A1
         K DIC S DIC="^VA(200,",DIC(0)="EMQZ",DIC("S")="S X(1)=$G(^(""PS"")) I X
          (1),$S('$P((X(1)),""^"",4):1,1:DT<$P((X(1)),""^"",4))" D ^DIC K DIC I 
          Y'>0 G A1
         S PSGPR=+Y,PSGPRN=$P(Y(0,0),"^"),PSGFOK(1)=""
         ;; START NCC T4 MODS >> 327*RJS
A2       D CLOZPRV^PSGOE82
         I $G(ANQX) W ! S PSGPR=PSTMPI,PSGPRN=PSTMPN  K PSTMPN,PSTMPI G A1
         K ANQX
         ;; END NCC T4 MODS << 327*RJS
OC55     ;
         ;Order check for Speed finish is triggered from OC531^PSGOESF
         I $G(PSGORD)]"P",$G(PSJSPEED) Q
         I $G(PSJOCFG)="SPEED RENEW" G CHKDD
         D NEWOC55^PSGOER
         I $G(PSGORQF) S COMQUIT=1 G DONE
CHKDD    ;
         G:$G(PSGRENEW) 106
         I PSGORD["P"!$$DDOK^PSGOE2("^PS(55,"_PSGP_",5,"_+PSGORD_",1,",PSGPDRG) 
          G 106
         ;I PSGORD["P"!'$$CHKDD^PSGOE2("^PS(55,"_PSGP_",5,"_+PSGORD_",") G 106
         I $P(PSJSYSU,";")'=3,'$P(PSJSYSP0,U,2) W !!,"This order's dispense drug
           is invalid, a pharmacist must renew this order." Q
         K ^PS(53.45,PSJSYSP,1),^(2)
         W !!,"THE DISPENSE DRUG IS MISSING FROM THIS ORDER."
         D ENDRG^PSGOEF1(+^PS(55,PSGP,5,+PSGORD,.2),0)
         I $G(DUOUT)!'$G(DRG) S COMQUIT=1 Q
106      ; nature of order
         S PSJNOO=$$ENNOO^PSJUTL5("R") S:PSJNOO<0 COMQUIT=1
         S:PSJNOO'<0 PSGFOK(106)=""
DONE     ;
         K F,F0,F1,PSGF2,F3,ND2,PSGDL,PSGDLS,PSGOROE1,PSGRO,SDT,X,Y Q
FF       ; "^" to another field
         K DIC S DIC="^DD(55.06,",DIC(0)="EQ",DIC("S")="I $D(PSGFOK(+Y))",X=$E(X
          ,2,255) D ^DIC K DIC
         S Y=+Y Q

*****   INDEX OF PSGOER0   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   %DT          25+5!*
>> ANOX         A1+4
   ANQX         A2+1,A2+2!
>> COMQUIT      25*,A1+2*,OC55+5*,CHKDD+8*,106+1*
   DIC          A1+7!*,FF+1!*
   DIC("S"      A1+7*,FF+1*
   DIC(0        A1+7*,FF+1*
>> DRG          CHKDD+8
   DT           DATE+9
   DTIME        25,A1+2
>> DUOUT        CHKDD+8
   DUR          D25!*,D25+1,D25+3
   DURMIN       D25!,D25+1*,D25+3*
   DUZ          DATE+7
   F            DONE+1!
   F0           DONE+1!
   F1           DATE+2*,DONE+1!
   F3           DONE+1!
>> ND           DATE+8
   ND2          25+4*,DONE+1!
   PKGFLG       D25~*
   PSGDL        25+4*,DONE+1!
   PSGDLS       25+4!,DONE+1!
   PSGDT        DATE~,DATE+10,DATE+12,O25+1,O25+3*,O25+4,D25+3,W25
   PSGF2        25+3*,1+1*,DONE+1!
>> PSGFD        O25+4*,O25+5*,D25+1*,D25+2,D25+4*,25+5*,W25,W25+1
>> PSGFDN       D25+4*,25,25+1,25+5*
   PSGFOK       DATE+1!
   PSGFOK(1     W25+5*,A1+4*,A1+8*
   PSGFOK(10    O25+5*
   PSGFOK(106   106+2*
   PSGFOK(25    W25+2*
>> PSGLI        DATE+10
   PSGNEDFD     DATE+1!,DATE+5*
   PSGNEFD      O25+1~,O25+4
   PSGNESD      O25+4~*
>> PSGODDD(1    W25+5
   PSGOEPR      DATE+1!,DATE+7*,DATE+8
   PSGOER0      DATE+1!,DATE+2*,DATE+6,DATE+7
   PSGOER2      DATE+1!,DATE+2*,DATE+6,DATE+9,DATE+12,D25+2,25+4
   PSGOERDP     DATE+1!,DATE+5*
   PSGOFD       DATE+1!,DATE+9*
>> PSGONF       W25+5
   PSGOPR       DATE+1!,DATE+7*,DATE+9*
   PSGORD       DATE~,DATE+2,DATE+3,D25,D25+3,OC55+2,CHKDD+2,CHKDD+7
   PSGOROE1     DONE+1!
>> PSGORQF      OC55+5
   PSGOSD       DATE+1!,DATE+9*,DATE+11,DATE+12
   PSGP         DATE~,DATE+2,DATE+3,O25+2,O25+5,D25,CHKDD+2,CHKDD+7
   PSGPDRG      DATE+1!,DATE+2*,DATE+3*,DATE+5,CHKDD+2
>> PSGPR        DATE+7*,DATE+8*,DATE+9*,A1+1,A1+2,A1+3,A1+4,A1+8*,A2+1*
   PSGPRI       DATE+1!,DATE+9*
   PSGPRN       DATE+1!,DATE+9*,A1+1,A1+2,A1+4,A1+8*,A2+1*
>> PSGRENEW     CHKDD+1
   PSGRNSD      DATE+1!,DATE+10*,O25+5,D25+1,25+4
   PSGRO        DATE+9*,25*,A1+2*,DONE+1!
   PSGS0XT      DATE+1!,DATE+6*
   PSGS0Y       DATE+1!,DATE+6*,DATE+12
   PSGSCH       DATE+1!,DATE+6*,25+4
   PSGSD        DATE+11*,DATE+12*,DATE+13,O25+1~*,O25+2,W25+1
   PSGSDN       DATE+1!,DATE+13*
   PSGST        DATE+1!,DATE+6*,DATE+12,O25+5
   PSGWLL       DATE+1!,DATE+2*
   PSJNOO       DATE+1!,106+1*,106+2
>> PSJOCFG      OC55+3
   PSJREN       DATE+12*!
>> PSJSPEED     DATE+8,OC55+2
>> PSJSYSP      CHKDD+5
>> PSJSYSP0     CHKDD+4
>> PSJSYSU      DATE+7,DATE+9,1+1,CHKDD+4
>> PSJSYSW0     O25+5,D25+4
   PSTMPI       A1+1*,A2+1!
   PSTMPN       A1+1*,A2+1!
   SDT          DONE+1!
   U            DATE+3,DATE+5,DATE+12,CHKDD+4
   X            O25+5*,D25+1*,D25+4,25*,25+1,25+2,25+3*,25+4,A1+2*,A1+3*,A1+4*
                A1+5,A1+6,DONE+1!,FF+1*
   XX           DATE+3~*,DATE+4
   Y            O25+4*,O25+5*,D25+1*,D25+2*,D25+3*,D25+4*,25+2,25+5,A1+6,A1+7
                A1+8,DONE+1!,FF+2*
   Y(0          A1+8

Global Variables  ( * Changed  ! Killed)
   ^PS(53.45           CHKDD+5!
   ^PS(55              DATE+2,CHKDD+7
   ^VA(200             DATE+9,A1+4

Naked Globals
   ^(           DATE+2
   ^("PS"       DATE+9,A1+4
   ^(2          DATE+2,CHKDD+5!

Cache Objects
   NONE

Marked Items
   NONE

Label References
   1            O25+5
   25           25+2,25+4,25+5,W25+1
   106          CHKDD+1,CHKDD+2
   @(           25+2,A1+6
   A1           A1+3,A1+6,A1+7,A2+1
   CHKDD        1+1,OC55+3
   DONE         DATE+4,25,A1+2,OC55+5
   FF           25+2,A1+6
   OC55         A1+4
   W25          25+1

External References
   ^%DT                25+5
   ^DIC                A1+7,FF+1
   $$ENDL^PSGDL        25+4
   ENGO^PSGDL          25+4
   $$ENDD^PSGMI        DATE+13,D25+4,25+5
   $$ENSD^PSGNE3       DATE+12
   ENFD^PSGNE3         O25+4
   ENWALL^PSGNE3       O25+2
   $$DDOK^PSGOE2       CHKDD+2
   $$GTNEDFD^PSGOE7    DATE+5
   CLOZPRV^PSGOE82     A2
   ENDRG^PSGOEF1       CHKDD+7
   ENHLP^PSGOEM        25+3,A1+3,A1+5
   NEWOC55^PSGOER      OC55+4
   $$ENOSD^PSJDCU      O25+5
   $$DURMIN^PSJLIVMD   D25+1,D25+3
   $$GETDUR^PSJLIVMD   D25
   $$ACTIVE^PSJORREN   DATE+3
   EFDNEW^PSJUTL       W25+4
   $$DATE2^PSJUTL2     O25+3
   $$ENNOO^PSJUTL5     106+1
   $$FMADD^XLFDT       D25+1,D25+3
   $$NOW^XLFDT         O25+3

*****   END   *****


PSGOESF  * *  104 Lines,  6582 Bytes, Checksum: B32063464
                                                  Jul 01, 2016@13:24:55 page 14
              1739 bytes in comments
PSGOESF  ;BIR/MLM-SPEED FINISH ORDERS ENTERED THROUGH OE/RR ;10 Mar 98 / 2:35 PM
         ;;5.0;INPATIENT MEDICATIONS ;**7,11,29,35,127,133,221,181,327**;16 DEC 
          97;Build 10
         ;
         ; Reference to ^PS(55 is supported by DBIA 2191
         ; Reference to ^PSDRUG( is supported by DBIA 2192
         ; Reference to ^PSSLOCK is supported by DBIA 2789
         ;
EN       ;
         I '$$HIDDEN^PSJLMUTL("SPEED") S VALMBCK="R" Q
         ;PSJ*5*221 Account for pending orders being below pending renewals
         N CODE,ST,DRG,ON,PSGONF,PSGONF2,PSGSFD,PENDCT
         D FULL^VALM1 S PSGLMT=PSJOCNT,(PSGONF,PSGONF2,PENDCT)=0
         S CODE="" F  S CODE=$O(^TMP("PSJ",$J,CODE)) Q:CODE=""  D
         .S ST="" F  S ST=$O(^TMP("PSJ",$J,CODE,ST)) Q:ST=""  D
         ..S DRG="" F  S DRG=$O(^TMP("PSJ",$J,CODE,ST,DRG)) Q:DRG=""  D
         ...S ON="" F  S ON=$O(^TMP("PSJ",$J,CODE,ST,DRG,ON)) Q:ON=""  S PSGONF=
          PSGONF+1 D
         ....I CODE="CC" S:$G(PSGONF2)=0 PSGONF2=PSGONF S PSGRLAST=PSGONF ;gets 
          first renewal #
         ....;PSJ*5*221 count pending orders to offset SF selection
         ....I CODE="CB" S PENDCT=PENDCT+1
         I PENDCT,$G(PSGRLAST) S PSGRLAST=PSGRLAST-PENDCT,PSGONF2=PSGONF2-PENDCT
         I PSGONF2'>0 W !,"There are no orders which can be Speed Finished at th
          is time.",!,"Only PENDING RENEWALS can be Speed Finished." D PAUSE^VAL
          M1 Q
         S PSGONF=PSGONF2_"^"_PSGRLAST
         N DIR,L1,L2 S L1=+PSGONF,L2=$P(PSGONF,U,2),DIR(0)="LAO^"_L1_":"_L2,DIR(
          "A")="FINISH which orders ("_L1_"-"_L2_"): ",DIR("?",1)="Select order"
          _$E("s",L1'=L2)_"to finish: ",DIR("??")="^D HELP^PSGOESF"
         D ^DIR K DIR I $D(DIRUT) K X G DONE
         I X?1N1"-" Q:$P(PSGONF,U,2)<X  S Y="" F L1=+X:1 S Y=Y_L1_"," Q:L1=$P(PS
          GONF,U,2)
         I 'Y W $C(7),!!,"??" G EN
ENCHK    ;
         S PSJSPEED=1
         K PSGODDD S PSGODDD=1,PSGODDD(1)="" F Q=1:1:$L(Y,",") S X1=$P(Y,",",Q) 
          D SET^PSGON Q:'$D(X)
         S PSGOSD=0 F PSGOERS=1:1:PSGODDD F PSGOERS1=1:1 S PSGOERS2=$P(PSGODDD(P
          SGOERS),",",PSGOERS1) Q:'PSGOERS2  S Y=+^TMP("PSJON",$J,PSGOERS2),F=$G
          (^PS(53.1,Y,0)),D=$G(^(.2)) D HMSG^PSGOERS I F G EN
         I $P(PSJSYSP0,"^",3) D  I '$D(PSGFOK) S X="" G DONE
         .S PSGORD=^TMP("PSJON",$J,+PSGODDD(1)),PSGOFD=$P($G(^PS(53.1,+PSGORD,2)
          ),U,4),DA=+PSGORD,DA(1)=PSGP,PSGSFD=$P($G(^PS(53.1,+PSGORD,0)),U,16)
         .S PSGORD=$P(^PS(53.1,+PSGORD,0),U,25)
         .S PSGWLL=$S($P(PSJSYSW0,"^",4):+$G(^PS(55,PSGP,5.1)),1:0),PSGOEE="R" W
           ! D DATE^PSGOER0(PSGP,PSGORD,PSGSFD)
         .I '$D(PSGFOK(1)) W $C(7),!,"...order",$E("s",$L(PSGODDD(1),",")>2)," N
          OT finished..." K PSGFOK Q
         .I 'PSGNEDFD,$P(PSJSYSW0,"^",4) D ENWALL^PSGNE3(PSGSD,PSGFD,PSGP)
         W ! F PSGOERS=1:1:PSGODDD F PSGOERS1=1:1 S PSGOERS2=$P(PSGODDD(PSGOERS)
          ,",",PSGOERS1) Q:'PSGOERS2  S PSGORD=^TMP("PSJON",$J,PSGOERS2),PSGOEFF
          =0 D
         .I '$$LS^PSSLOCK(PSGP,PSGORD) W !,"  ",PSGOERS2,". ",$P($$DRUGNAME^PSJL
          MUTL(PSGP,PSGORD),"^")," ",$P($G(^PS(53.1,+PSGORD,.2)),"^",2),!,"...No
           action taken on this order...",! H 1 Q
         .;K PSGORQF D ENDDC^PSGSICHK(PSGP,+$G(^PS(53.1,+PSGORD,1,1,0)))
         .;I '$D(PSGORQF) K PSGORQF,^TMP($J,"DI") D
         .;. F PSGDDI=1:0 S PSGDDI=$O(^PS(53.1,+PSGORD,1,PSGDDI)) Q:'PSGDDI  S P
          SJDD=+$G(^PS(53.1,+PSGORD,1,PSGDDI,0)) D IVSOL^PSGSICHK
         .S X=$G(^PS(53.1,+PSGORD,.2)),PSGPDRGN=$$ENPDN^PSGMI(+X),PSGDO=$P(X,U,2
          ),X=$G(^PS(53.1,+PSGORD,0)),PSGMRN=$$ENMRN^PSGMI($P(X,U,3)),PSGST=$P(X
          ,U,7)
         .S PSGSCH=$P($G(^PS(53.1,+PSGORD,2)),U),PSGSI=$G(^(6))
         .D OC531
         .I 'PSGOEFF&($D(PSGORQF)) W !!,"  ",PSGOERS2,". ",$P($$DRUGNAME^PSJLMUT
          L(PSGP,PSGORD),"^")," ",$P($G(^PS(53.1,+PSGORD,.2)),"^",2),!,"...No ac
          tion taken on this order...",! H 1 Q
         .;S X=$G(^PS(53.1,+PSGORD,.2)),PSGPDRGN=$$ENPDN^PSGMI(+X),PSGDO=$P(X,U,
          2),X=$G(^PS(53.1,+PSGORD,0)),PSGMRN=$$ENMRN^PSGMI($P(X,U,3)),PSGST=$P(
          X,U,7)
         .;S PSGSCH=$P($G(^PS(53.1,+PSGORD,2)),U),PSGSI=$G(^(6))
         .S $P(^PS(53.1,+PSGORD,2),U,2)=PSGSD,$P(^(2),U,4)=PSGFD,X=+$P($G(^PS(53
          .1,+PSGORD,0)),U,25)
         .I $P($G(^PS(55,PSGP,5,+X,2)),U,4)>PSGSD S $P(^(2),U,3)=$P(^(2),U,4) K 
          DA,DIE,DR S DA(1)=PSGP,DA=X,DR="34////"_PSGSD,DIE="^PS(55,"_DA(1)_",5,
          " D ^DIE
         .W !!,"  ",PSGOERS2,". ",$P($$DRUGNAME^PSJLMUTL(PSGP,PSGORD),"^")," "
         .W $P($G(^PS(53.1,+PSGORD,.2)),"^",2)
         .D UPDATE
         .D EN^PSGOEV(PSGORD)
         .D UNL^PSSLOCK(PSGP,PSGORD)
         ;
DONE     ; Kill and exit.
         S DIR(0)="E" D ^DIR K DIR
         I $G(PSGPXN) D ^PSGPER1
         K PSJSPEED,PSGODDD,PSGOERS,PSGORD,PSGOERS2,PSGPDRGN,PSGDO,PSGSCH,PSGSI,
          NF,Y,PSGRLAST
         Q
HELP        ; Display help text for select order to be finished prompt."
         W !!,"  Select the orders to be speed finished. Only orders listed unde
          r the PENDING",!,"RENEWALS heading are selectable. The start and stop 
          date/times specified will"
          W !,"be used for all orders selected to be finished using this functio
          n.",!
         Q
UPDATE          ;
         N LOOP K ^PS(53.45,PSJSYSP,2)
         F LOOP=0:0 S LOOP=$O(^PS(53.1,+PSGORD,1,LOOP)) Q:'LOOP  D
         .S ^PS(53.45,PSJSYSP,2,LOOP,0)=^PS(53.1,+PSGORD,1,LOOP,0)
         .S PSJJDRUG=$P(^PS(53.1,+PSGORD,1,LOOP,0),"^")
         .S ^PS(53.45,PSJSYSP,2,"B",PSJJDRUG,LOOP)=""
         .S ^PS(53.45,PSJSYSP,2,0)="^53.4502P"_"^"_LOOP_"^"_LOOP K PSJJDRUG
         Q
OC531    ;* Order checks for Speed finish and regular finish
         ;PSJOCDS("ON_TYPE") - Order type of either "UD" or "IV"
         ;PSJOCDS - 0/1 (O - will exclude dose check.  1 - include the dose chec
          k for the prospective)
         N INTERVEN,PSJDDI,PSJIREQ,PSJRXREQ,PSJPDRG,PSJDD,PSJALLGY,PSJOCDS,PSJX,
          PSGDT,%
         D NOW^%DTC S PSGDT=%
         S Y=1,(PSJIREQ,PSJRXREQ,INTERVEN,X)=""
         ;K PSGORQF D ENDDC^PSGSICHK(PSGP,+$G(^PS(53.1,+PSGORD,1,1,0)))
         ;I '$D(PSGORQF) K PSGORQF,^TMP($J,"DI") D
         ;. F PSGDDI=1:0 S PSGDDI=$O(^PS(53.1,+PSGORD,1,PSGDDI)) Q:'PSGDDI  S PS
          JDD=+$G(^PS(53.1,+PSGORD,1,PSGDDI,0)) K PSJPDRG D IVSOL^PSGSICHK
         I $G(PSJSPEED) D
         . F PSGDDI=0:0 S PSGDDI=$O(^PS(53.1,+PSGORD,1,PSGDDI)) Q:'PSGDDI  D
         .. S PSJDD=+$G(^PS(53.1,+PSGORD,1,PSGDDI,0))
         .. S PSJX=$S('$D(^PSDRUG(+PSJDD,0)):1,$P($G(^(2)),U,3)'["U":1,$G(^("I")
          )="":0,1:^("I")'>$G(PSGDT))
         .. Q:PSJX
         .. S PSJALLGY(PSJDD)=""
         I '+$G(PSJSPEED) S PSJDD=$$DD53P45^PSJMISC()
         S PSJDD=$O(PSJALLGY(0)) Q:'+PSJDD
         K PSGORQF D ENDDC^PSGSICHK(PSGP,PSJDD)
         ;Only do dosing check for speed finish. Regular finish will do dosing c
          heck at ENCKDD^PSGOEF1
         ;;START NCC T4 MODS >> 327*RJS
         ;I $P($G(^PSDRUG(PSJDD,"CLOZ1")),"^")="PSOCLO1" W !,"Now doing Clozapin
          e Order checks.  Please wait...",! D
         ;. N RTN,ANQX
         ;. S ANQX=1,RTN=$P($G(^PSDRUG(PSJDD,"CLOZ1")),U)
         ;. D:$L(RTN) ^@RTN
         ;. S:$G(ANQX) PSGOEFF=1
         ;; END NCC T4 MODS << 327*RJS
         I '+$G(PSJSPEED),$G(PSGOEFF) Q
         ;For some reasons PSGMR is not define when SF a UD order
         ;If user was not required to enter a DD (order was able to default a DD
          ), need to get dosing check
         NEW PSGMR I ($G(PSGORD)["P") S PSGMR=$P($G(^PS(53.1,+PSGORD,0)),U,3)
         D:'$G(PSGORQF) IN^PSJOCDS($G(PSGORD),"UD",+PSJDD)
         Q

*****   INDEX OF PSGOESF   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   %            OC531+3~,OC531+4
   CODE         EN+3~,EN+5*,EN+6,EN+7,EN+8,EN+9,EN+11
>> D            ENCHK+3*
   DA           ENCHK+5*,ENCHK+22!*
   DA(1         ENCHK+5*,ENCHK+22*
   DIE          ENCHK+22!*
   DIR          EN+15~,EN+16!,DONE+1!
   DIR("?"      EN+15*
   DIR("??"     EN+15*
   DIR("A"      EN+15*
   DIR(0        EN+15*,DONE+1*
>> DIRUT        EN+16
   DR           ENCHK+22!*
   DRG          EN+3~,EN+7*,EN+8
>> F            ENCHK+3*
   INTERVEN     OC531+3~,OC531+5*
   L1           EN+15~*,EN+17*
   L2           EN+15~*
   LOOP         UPDATE+1~,UPDATE+2*,UPDATE+3,UPDATE+4,UPDATE+5,UPDATE+6
   NF           DONE+3!
   ON           EN+3~,EN+8*
   PENDCT       EN+3~,EN+4*,EN+11*,EN+12
>> PSGDDI       OC531+10*,OC531+11
   PSGDO        ENCHK+15*,DONE+3!
   PSGDT        OC531+3~,OC531+4*,OC531+12
>> PSGFD        ENCHK+9,ENCHK+21
   PSGFOK       ENCHK+4,ENCHK+8!
   PSGFOK(1     ENCHK+8
>> PSGLMT       EN+4*
   PSGMR        OC531+29~*
>> PSGMRN       ENCHK+15*
>> PSGNEDFD     ENCHK+9
   PSGODDD      ENCHK+2!*,ENCHK+3,ENCHK+10,DONE+3!
   PSGODDD(     ENCHK+3,ENCHK+10
   PSGODDD(1    ENCHK+2*,ENCHK+5,ENCHK+8
>> PSGOEE       ENCHK+7*
>> PSGOEFF      ENCHK+10*,ENCHK+18,OC531+26
   PSGOERS      ENCHK+3*,ENCHK+10*,DONE+3!
>> PSGOERS1     ENCHK+3*,ENCHK+10*
   PSGOERS2     ENCHK+3*,ENCHK+10*,ENCHK+11,ENCHK+18,ENCHK+23,DONE+3!
>> PSGOFD       ENCHK+5*
   PSGONF       EN+3~,EN+4*,EN+8*,EN+9,EN+14*,EN+15,EN+17
   PSGONF2      EN+3~,EN+4*,EN+9*,EN+12*,EN+13,EN+14
   PSGORD       ENCHK+5*,ENCHK+6*,ENCHK+7,ENCHK+10*,ENCHK+11,ENCHK+15,ENCHK+16
                ENCHK+18,ENCHK+21,ENCHK+23,ENCHK+24,ENCHK+26,ENCHK+27,DONE+3!
                UPDATE+2,UPDATE+3,UPDATE+4,OC531+10,OC531+11,OC531+29,OC531+30
   PSGORQF      ENCHK+18,OC531+17!,OC531+30
>> PSGOSD       ENCHK+3*
>> PSGP         ENCHK+5,ENCHK+7,ENCHK+9,ENCHK+11,ENCHK+18,ENCHK+22,ENCHK+23
                ENCHK+27,OC531+17
   PSGPDRGN     ENCHK+15*,DONE+3!
>> PSGPXN       DONE+2
   PSGRLAST     EN+9*,EN+12*,EN+14,DONE+3!
   PSGSCH       ENCHK+16*,DONE+3!
>> PSGSD        ENCHK+9,ENCHK+21,ENCHK+22
   PSGSFD       EN+3~,ENCHK+5*,ENCHK+7
   PSGSI        ENCHK+16*,DONE+3!
>> PSGST        ENCHK+15*
>> PSGWLL       ENCHK+7*
   PSJALLGY     OC531+3~
   PSJALLGY(    OC531+14*
   PSJALLGY(0   OC531+16
   PSJDD        OC531+3~,OC531+11*,OC531+12,OC531+14,OC531+15*,OC531+16*
                OC531+17,OC531+30
   PSJDDI       OC531+3~
   PSJIREQ      OC531+3~,OC531+5*
   PSJJDRUG     UPDATE+4*,UPDATE+5,UPDATE+6!
   PSJOCDS      OC531+3~
>> PSJOCNT      EN+4
   PSJPDRG      OC531+3~
   PSJRXREQ     OC531+3~,OC531+5*
   PSJSPEED     ENCHK+1*,DONE+3!,OC531+9,OC531+15,OC531+26
>> PSJSYSP      UPDATE+1,UPDATE+3,UPDATE+5,UPDATE+6
>> PSJSYSP0     ENCHK+4
>> PSJSYSW0     ENCHK+7,ENCHK+9
   PSJX         OC531+3~,OC531+12*,OC531+13
>> Q            ENCHK+2*
   ST           EN+3~,EN+6*,EN+7,EN+8
   U            EN+15,EN+17,ENCHK+5,ENCHK+6,ENCHK+15,ENCHK+16,ENCHK+21,ENCHK+22
                OC531+12,OC531+29
>> VALMBCK      EN+1*
   X            EN+16!,EN+17,ENCHK+2,ENCHK+4*,ENCHK+15*,ENCHK+21*,ENCHK+22
                OC531+5*
>> X1           ENCHK+2*
   Y            EN+17*,EN+18,ENCHK+2,ENCHK+3*,DONE+3!,OC531+5*

Global Variables  ( * Changed  ! Killed)
   ^PS(53.1            ENCHK+3,ENCHK+5,ENCHK+6,ENCHK+11,ENCHK+15,ENCHK+16
                       ENCHK+18,ENCHK+21*,ENCHK+24,UPDATE+2,UPDATE+3,UPDATE+4
                       OC531+10,OC531+11,OC531+29
   ^PS(53.45           UPDATE+1!,UPDATE+3*,UPDATE+5*,UPDATE+6*
   ^PS(55              ENCHK+7,ENCHK+22
   ^PSDRUG(            OC531+12
   ^TMP("PSJ"          EN+5,EN+6,EN+7,EN+8
   ^TMP("PSJON"        ENCHK+3,ENCHK+5,ENCHK+10

Naked Globals
   ^(           ENCHK+3
   ^("I"        OC531+12
   ^(2          ENCHK+21*,ENCHK+22*,OC531+12
   ^(6          ENCHK+16

Cache Objects
   NONE

Marked Items
   NONE

Label References
   DONE         EN+16,ENCHK+4
   EN           EN+18,ENCHK+3
   OC531        ENCHK+17
   UPDATE       ENCHK+25

External References
   NOW^%DTC            OC531+4
   ^DIE                ENCHK+22
   ^DIR                EN+16,DONE+1
   $$ENMRN^PSGMI       ENCHK+15
   $$ENPDN^PSGMI       ENCHK+15
   ENWALL^PSGNE3       ENCHK+9
   DATE^PSGOER0        ENCHK+7
   HMSG^PSGOERS        ENCHK+3
   EN^PSGOEV           ENCHK+26
   SET^PSGON           ENCHK+2
   ^PSGPER1            DONE+2
   ENDDC^PSGSICHK      OC531+17
   $$DRUGNAME^PSJLMUTL ENCHK+11,ENCHK+18,ENCHK+23
   $$HIDDEN^PSJLMUTL   EN+1
   $$DD53P45^PSJMISC   OC531+15
   IN^PSJOCDS          OC531+30
   $$LS^PSSLOCK        ENCHK+11
   UNL^PSSLOCK         ENCHK+27
   FULL^VALM1          EN+4
   PAUSE^VALM1         EN+13

*****   END   *****


PSGOEV   * *  195 Lines,  12136 Bytes, Checksum: B92599651
                                                  Jul 01, 2016@13:24:55 page 15
              1756 bytes in comments
PSGOEV   ;BIR/CML3 - VERIFY (MAKE ACTIVE) ORDERS ;4/16/10 9:18am
         ;;5.0;INPATIENT MEDICATIONS;**5,7,15,28,33,50,64,58,77,78,80,110,111,13
          3,171,207,241,267,268,260,288,199,281,327**;16 DEC 97;Build 10
         ;
         ; Reference to ^ORD(101 supported by DBIA #872.
         ; Reference to ^PS(50.7 supported by DBIA #2180.
         ; Reference to ^PS(55 supported by DBIA #2191.
         ; Reference to ^PSSLOCK supported by DBIA #2789.
         ; Reference to ^PSDRUG( supported by DBIA# 2192.
         ; Reference to MAIN^TIUEDIT is supported by DBIA #2410.
         ; Reference to ^TMP("PSODAOC",$J supported by DBIA 6071
         ;
EN(PSGORD) --
          ;
ENSF     ; This entry point is used by Speed finish only.
         ; Send SN update to CPRS if auto-verify off and from Order Set entry
         S:'$D(PSGOEAV) PSGOEAV=$P($G(PSJSYSP0),"^",9)&$G(PSJSYSU)
         I $D(PSGOES),'PSGOEAV,PSGORD["P",$P($G(^PS(53.1,+PSGORD,0)),"^",21)']""
           D ORSET^PSGOETO1
         D FULL^VALM1 I 'PSJSYSU W $C(7),$C(7),!!," THIS FUNCTION NOT AVAILABLE 
          TO WARD STAFF." Q
         S CHK=0 I PSGORD["P" S X=$P($G(^PS(53.1,+PSGORD,0)),"^",19) I X,$D(^PS(
          55,PSGP,5,$P(^(0),"^",19))) S CHK=+PSGORD,PSGORD=X_"U" L -^PS(53.1,CHK
          ) L +^PS(55,PSGP,5,+PSGORD):1 E  W !!,"Another terminal is editing thi
          s order." G DONE
         I +PSJSYSU=3 D DDCHK G:CHK DONE
         I PSGORD["P" D CHK($G(^PS(53.1,+PSGORD,0)),$G(^(.2)),$G(^(2)))
         I $G(PSGSCH)]"" D
         .N X,Y,PSGS0Y,PSGS0XT,PSGOES S PSGOES=1 S X=PSGSCH D ENOS^PSGS0 I $G(X)
          ="" S CHK=4
         I $G(CHK) Q:$D(PSJSPEED)  D EN^VALM("PSJU LM ACCEPT") G:'$G(PSJACEPT) D
          ONE ;G VFY
         I PSGORD["U" G:'$D(^PS(55,PSGP,5,+PSGORD,4)) VFY I +PSJSYSU=3,$P(^(4),"
          ^",3) W $C(7),!!,"THIS ORDER HAS ALREADY BEEN VERIFIED BY A PHARMACIST
          ." S PSGACT=$P(PSGACT,"V")_$P(PSGACT,"V",2) G DONE
         I PSGORD["U" I +PSJSYSU=1,+^PS(55,PSGP,5,+PSGORD,4) W $C(7),!!,"THIS OR
          DER HAS ALREADY BEEN VERIFIED BY A NURSE." S PSGACT=$P(PSGACT,"V")_$P(
          PSGACT,"V",2) G DONE
         ;
VFY      ; change status, move to 55, and change label record **ENHANCEMENTS MAD
          E IN PSJ*5.0*260 **CCR 6214 **CCR 6244
         I PSGORD["P" S PSJCOM=+$P($G(^PS(53.1,+PSGORD,.2)),"^",8) I PSJCOM D VF
          Y^PSJCOM Q
         NEW PSJDOSE,PSJDSFLG,PSJDIS,PSGORQF,PSJCNT,PSJCNT1,PSJCNT2,LIST,PSJFLG,
          PSGDN SET PSJDIS="",PSJCNT=0,PSJCNT1="",PSJCNT2="",LIST="PSGPRE",PSJFL
          G="",PSGDN=""
         D DOSECHK^PSJDOSE
         SET PSJFLG=+$G(PSGORD)
         FOR  SET PSJCNT=$O(^PS(53.1,PSJFLG,1,PSJCNT)) Q:'+PSJCNT  D
         .IF $D(^PS(53.1,PSJFLG,1,PSJCNT,0)) SET PSGDN=$P($G(^PS(53.1,PSJFLG,1,P
          SJCNT,0)),U,1)
         .IF +$G(PSGDN),($P($G(^PSDRUG(PSGDN,0)),U,3)'["S")&($E($P($G(^PSDRUG(PS
          GDN,0)),U,2),1,2)'="XA")  D
         ..D PROFILE^PSJBLDOC($G(DFN),LIST,"I;"_$G(PSGORD))
         ..FOR  SET PSJCNT1=$O(^TMP($J,LIST,"IN","PROFILE",PSJCNT1)) Q:(PSJCNT1=
          "")!(PSJDIS'="")  D
         ...SET PSJCNT2=$P(PSJCNT1,";",2)
         ...IF PSJCNT2=$G(PSGORD) SET PSJDIS=$P(^TMP($J,LIST,"IN","PROFILE",PSJC
          NT1),U,3)
         ..;**Do order checks if PSJDIS (Dispense drug IEN) has a value
         ..;IF $G(PSJNEWOE)=0,'$G(PSJLMFIN),'$G(PSJSTARI),'$G(PSGCOPY),$G(PSJDIS
          ),'$G(PSJSPEED)  D
         ..IF '+$G(PSJNEWOE),'$G(PSJLMFIN),'$G(PSJSTARI),'$G(PSGCOPY),$G(PSJDIS)
          ,'$G(PSJSPEED)  D
         ...D ALLERGY($G(PSJORD),.PSJALLGY),ENDDC^PSGSICHK($G(PSGP),PSJDIS) D:('
          $G(PSGORQF)&'$G(PSJDSVFY)&'$G(PSJSTARI)) IN^PSJOCDS($G(PSGORD),"UD",PS
          JDIS) IF $G(PSGORQF) K ^TMP($J,LIST) D:$G(PSJORD)]"" EN^VALM("PSJ LM U
          D ACTION") QUIT
         IF $G(PSGORQF) QUIT
         D FULL^VALM1 ;PSJ*5*241
         I +$G(PSJDSFLG) D SETVAR^PSJDOSE W !!,PSJDOSE("WARN"),!,PSJDOSE("WARN1"
          ) I '$$CONT() W !,"...order was not verified..." D PAUSE^VALM1 D  Q:'$
          G(PSJACEPT)
         . S PSGOEEF(109)=1
         . S PSJACEPT=0
         . ;D EN^VALM("PSJU LM ACCEPT")
         D DDCHK G:CHK DONE
         I $G(PSGSCH)]"",((",P,R,")'[(","_PSGST_",")) D  I CHK G DONE
         .N SWD,SDW,XABB,X,QX S X=$G(PSGSCH) D DW^PSGS0 Q:($G(X)="")  I $G(PSGS0
          XT)="" S PSGS0XT="D"
         .I $G(PSGS0XT)="D",$G(PSGAT)="" S CHK=1 W !!,"This is a 'DAY OF WEEK' s
          chedule and MUST have admin times.",! D PAUSE^VALM1
         I $G(PSGSCH)]"" D  I CHK G DONE
         .N X,Y,PSGS0XT,PSGS0Y,PSGOES S PSGOES=2,X=PSGSCH D ENOS^PSGS0 I $G(X)="
          " S CHK=4
         W !,"...a few moments, please..."
         I PSGORD["P" D
         . N PND0,PSGORDR,PSJPRIO,PSJSCHED S PND0=^PS(53.1,+PSGORD,0) I $P(PND0,
          U,24)="R" S PSGORDR=$P(PND0,U,25) D  Q
         .. N OEORD,OOEORD,FILE55,FILE55N0 S FILE55="^PS(55,"_DFN_$S($P(PND0,U,4
          )="U":",5,",1:",""IV"","),FILE55N0=FILE55_+PSGORDR_",0)"
         .. S OEORD=$P(PND0,U,21) I PSGORDR S OOEORD=$P(@FILE55N0,"^",21) I OEOR
          D'=OOEORD D EXPOE^PSGOER(DFN,PSGORD,+$$LASTREN^PSJLMPRI(DFN,PSGORD))
         .. S PSGORDP=PSGORD,DIE="^PS(53.1,",DA=+PSGORD,DR="28////A;104////@" W 
          "." D ^DIE
         .. D START^PSGOTR(PSGORD,+PSGORDR) I OEORD D
         ... K DA,DR,DIE S DA(1)=DFN,DA=+PSGORDR,DIE=FILE55,DR=$S(DIE["IV":110,1
          :66)_"////"_+OEORD D ^DIE S DIE=FILE55_+PSGORDR_",0)",$P(@DIE,U,21)=OE
          ORD
         ... D EN1^PSJHL2(DFN,"SC",PSGORDR),EN^PSGPEN(PSGORDR),UNL^PSSLOCK(PSGP,
          PSGORDR)
         . S PSGORDP=PSGORD ;Used in ACTLOG to update activity log in 55
         . D REQDT^PSJLIVMD(PSGORD)
         . S DIE="^PS(53.1,",DA=+PSGORD,DR="28////A" W "." D ^DIE,^PSGOT
         . S PSJPRIO=$S(PSGORD["P":$P($G(^PS(53.1,+PSGORD,.2)),"^",4),PSGORD["U"
          :$P($G(^PS(55,DFN,5,+PSGORD,.2)),"^",4),1:$P($G(^PS(55,PSJHLDFN,"IV",+
          PSGORD,.2)),"^",4))
         . S PSJSCHED=$S(PSGORD["P":$P($G(^PS(53.1,+PSGORD,2)),"^"),PSGORD["U":$
          P($G(^PS(55,DFN,5,+PSGORD,2)),"^"),1:$P($G(^PS(55,PSJHLDFN,"IV",+PSGOR
          D,0)),"^",15))
         . I (",S,A,")[(","_$G(PSJPRIO)_",")!($G(PSJSCHED)="NOW")!($G(PSJSCHED)[
          "STAT") D NOTIFY^PSJHL4(PSGORD,DFN,$G(PSJPRIO),$G(PSJSCHED))
         . I $G(PSGRDTX)="" S PSGRDTX=$G(^PS(53.1,+PSGORDP,2.5))
         S DA=+PSGORD,DA(1)=PSGP,PSGAL("C")=PSJSYSU*10+22000 D ^PSGAL5 W "." S V
          ND4=$G(^PS(55,PSGP,5,DA,4))
         I $G(PSGRDTX) D NEWUDAL^PSGAL5(PSGP,PSGORD,6090,"Requested Start Date",
          +$G(PSGRDTX))
         I $P($G(PSGRDTX),U,3) D NEWUDAL^PSGAL5(PSGP,PSGORD,6090,"Requested Stop
           Date",+$P($G(PSGRDTX),U,3))
         N DUR,DURON S DURON=$S($G(PSGORD):$G(PSGORD),1:"") I DURON D
         . S DUR=$S($P($G(PSGRDTX),U,2)]"":$P($G(PSGRDTX),U,2),1:$$GETDUR^PSJLIV
          MD(PSGP,+DURON,$S($G(DURON)["P":"P",1:5),1),1:"")
         I $G(DUR)]"" S $P(^PS(55,PSGP,5,+PSGORD,2.5),"^",2)=DUR
         D:$D(PSGORDP) ACTLOG(PSGORDP,PSGP,PSGORD)
         K PSGRSD,PSGRFD,PSGALFN
         NEW X S X=0 I $G(PSGONF),(+$G(PSGODDD(1))'<+$G(PSGONF)) S X=1
         I +PSJSYSU=3,PSGORD'["O",$S(X:0,'$P(VND4,"^",9):1,1:$P(VND4,"^",15)) D 
          EN^PSGPEN(+PSGORD)
         S $P(VND4,"^",+PSJSYSU=1+9)=1 S:'$P(VND4,U,+PSJSYSU=3+9) $P(VND4,U,+PSJ
          SYSU=3+9)=+$P(VND4,U,+PSJSYSU=3+9)
         I PSJSYSL>1 S $P(^PS(55,PSGP,5,+PSGORD,7),U)=PSGDT S:$P(^(7),U,2)="" $P
          (^(7),U,2)="N"_$S($P(^PS(55,PSGP,5,+PSGORD,0),"^",24)="E":"E",1:"") S 
          PSGTOL=2,PSGUOW=DUZ,PSGTOO=1,DA=+PSGORD D ENL^PSGVDS
         S:$P(VND4,"^",15)&'$P(VND4,"^",16) $P(VND4,"^",15)="" S:$P(VND4,"^",18)
          &'$P(VND4,"^",19) $P(VND4,"^",18)="" S:$P(VND4,"^",22)&'$P(VND4,"^",23
          ) $P(VND4,"^",22)="" S $P(VND4,"^",PSJSYSU,PSJSYSU+1)=DUZ_"^"_PSGDT,^P
          S(55,PSGP,5,+PSGORD,4)=VND4
         I '$P(VND4,U,9) S ^PS(55,"APV",PSGP,+PSGORD)=""
         I '$P(VND4,U,10) S ^PS(55,"ANV",PSGP,+PSGORD)=""
         I $P(VND4,U,9) K ^PS(55,"APV",PSGP,+PSGORD)
         I $P(VND4,U,10) K ^PS(55,"ANV",PSGP,+PSGORD)
         W:'$D(PSJSPEED) ! W !,"ORDER VERIFIED.",!
         I '$D(PSJSPEED) K DIR S DIR(0)="E" D ^DIR K DIR
         S:+PSJSYSU=3 ^PS(55,"AUE",PSGP,+PSGORD)="" S PSGACT="C"_$S('$D(^PS(55,P
          SGP,5,+PSGORD,4)):"E",$P(^(4),"^",16):"",1:"E")_"RS",PSGCANFL=2
         S VALMBCK="Q" D EN1^PSJHL2(PSGP,$S(+PSJSYSU=3:"SC",+PSJSYSU=1:"SC",1:"X
          X"),+PSGORD_"U")     ; allow status change to be sent for pharmacists 
          & nurses
         S ^TMP("PSODAOC",$J,"IP IEN")=$G(PSJORD),^TMP("PSODAOC",$J,"IP NEW IEN"
          )=$G(PSGORD)
         ; -- RTC 198753 - clean-up variable - K PSJAGYSV
         D SETOC^PSJNEWOC(PSGORD) K PSJAGYSV
          ; **This is where the Automated Dispensing Machine hook is called. Do 
          NOT DELETE or change this location **
         ;; START NCC REMEDIATION >> 327*RJS
         D NEWJ^PSJADM,CLOZSND^PSJOE
         ;; END NCC REMEDIATION << 327*RJS
         ; **END of Interface hook **
          ; **END of Interface hook **
         D:+PSJSYSU=1 EN1^PSJHL2(PSGP,"ZV",+PSGORD_"U")
DONE     ;
         W:CHK !!,"...order NOT verified..."
         I '$D(PSJSPEED),'CHK,+PSJSYSU=3,$G(PSJPRI)="D" D
         .N DIR W ! S DIR(0)="S^Y:Yes;N:No",DIR("A")="Do you want to enter a Pro
          gress Note",DIR("B")="No" D ^DIR
         .Q:Y="N"
         .D MAIN^TIUEDIT(3,.TIUDA,PSGP,"","","","",1)
         S VALMBCK="Q" K CHK,DA,DIE,F,DP,DR,ND,PSGAL,PSGODA,PSGTOL,PSGTOO,PSGUOW
          ,PSJDOSE,PSJVAR,VND4,X,ZZND Q
         ;
LBL      ;
         Q
         ;
ALLERGY(PSGORD,PSJALLGY) --
          ;setup PSJALLGY when non-vf was selected to verify
         NEW PSGDDI,PSJDD,PSJX
         I '+$G(PSGORD),($G(PSGORD)'["P") Q
         F PSGDDI=0:0 S PSGDDI=$O(^PS(53.1,+PSGORD,1,PSGDDI)) Q:'PSGDDI  D
         . S PSJDD=+$G(^PS(53.1,+PSGORD,1,PSGDDI,0))
         . S PSJX=$S('$D(^PSDRUG(+PSJDD,0)):1,$P($G(^(2)),U,3)'["U":1,$G(^("I"))
          ="":0,1:^("I")'>$G(DT))
         . Q:PSJX
         . S PSJALLGY(PSJDD)=""
         Q
CHK(ND,DRG,ND2) --
          ; checks for data in required fields
         ; Input: ND  - ^(PS(53.1,PSGORD,0)
         ;        DRG - ^(.2)
         ;        ND2 - ^(2)
         S Y=$G(Y)
         S CHK="" I DRG,$D(^PS(50.7,+DRG,0))
         E  S CHK=1
         I ND="" S CHK=CHK_23
         E  S CHK=CHK_$S($P(ND,"^",3):"",1:2)_$S($P(ND,"^",7)]"":"",1:3)
         ;The naked reference on the line below refers to the variable ND which 
          is ^PS(53.1,PSGORD,0).
         I ND2="" S CHK=CHK_$S('$D(^(0)):4,$P(^(0),"^",7)="OC":"",1:4)_56
         E  S CHK=CHK_$S($P(ND2,"^")]"":"",ND="":4,$P(ND,"^",7)="OC":"",1:4)_$S(
          $P(ND2,"^",2):"",1:5)_$S($P(ND2,"^",4):"",1:6)
         I $$CHECK^PSGOE8(PSJSYSP),$P(DRG,U,2)="" S CHK=CHK_8
         K PSGDFLG,PSGPFLG S PSGDI=0
         S:'$$DDOK^PSGOE2("^PS(53.45,"_PSJSYSP_",2,",+DRG) CHK=CHK_7,(PSGDFLG,PS
          GDI)=1
         S:'$$OIOK^PSGOE2(+DRG) PSGPFLG=1
         I 'CHK,$G(PSGSCH)]"" D
         .N X,Y,PSGS0Y,PSGS0XT,PSGOES S PSGOES=2,X=PSGSCH D ENOS^PSGS0 I $G(X)="
          " S CHK=4
         Q:'CHK
         W $C(7)
         ;
CHKM     ;
         D FULL^VALM1 K:CHK Y
         ; changed to remove ^DD ref
         ; PSJ*5*267 VMP Add the 8th condition
         W !!,"THE FOLLOWING ",$S($L(CHK)>1:"ARE",1:"IS")," EITHER INVALID OR MI
          SSING FROM THIS ORDER:" F X=1:1:8 W:CHK[X !?5,$P("ORDERABLE ITEM^MED R
          OUTE^SCHEDULE TYPE^SCHEDULE^START DATE/TIME^STOP DATE/TIME^DISPENSE DR
          UG^DOSAGE ORDERED","^",X)
         I CHK=7 W !,"Orders with no dispense drugs or multiple dispense drugs",
          !,"require dosage ordered"
         W:CHK]"" !!,$S($L(CHK)>1:"THESE FIELDS ARE",1:"THIS FIELD IS")," NECESS
          ARY FOR VERIFICATION."
         N DIR,DUOUT,DTOUT S DIR(0)="E" D ^DIR I $D(DUOUT)!$D(DTOUT) S CHK=1 Q
         Q
         ;
CONT()   ;
         NEW DIR,DIRUT,Y
         W ! K DIR,DIRUT
         S DIR(0)="Y",DIR("A")="Would you like to continue verifying the order",
          DIR("B")="No"
         D ^DIR
         Q Y
         ;
DDCHK    ; dispense drug check
         S DRGF="^PS("_$S(PSGORD["P":"53.1,"_+PSGORD,1:"55,"_PSGP_",5,"_+PSGORD)
          _",",CHK=$S('$O(@(DRGF_"1,0)")):7,1:0)
         S PSGPD=$G(@(DRGF_".2)"))
         S CHK=$S('$$DDOK^PSGOE2(DRGF_"1,",PSGPD):7,1:0)
         Q:CHK=0
         W $C(7),!!,"This order must have at least one valid, active dispense dr
          ug to be verified."
         ;
DDEDIT   ;
         ;*** Remove all dispense drug for this order
         K @(DRGF_"1)")
         ; The naked reference below refers to the indirect full reference in DR
          GF_"1,"_Q_")", which is either ^PS(53.1,+PSGORD,Q) or ^PS(55,DFN,5,+PS
          GORD,Q)
         K ^PS(53.45,PSJSYSP,2) S (X,Q)=0 F  S Q=$O(@(DRGF_"1,"_Q_")")) Q:'Q  S 
          Y=$G(^(Q,0)),X=Q S ^PS(53.45,PSJSYSP,2,Q,0)=Y I Y S ^PS(53.45,PSJSYSP,
          2,"B",+Y,Q)=""
         I X S ^PS(53.45,PSJSYSP,2,0)="^53.4502P^"_X_"^"_X
         D ENDRG^PSGOEF1(PSGPD,X)
         I 'CHK S %X="^PS(53.45,"_PSJSYSP_",2,",%Y=DRGF_"1," D %XY^%RCR S $P(@(D
          RGF_"1,0)"),"^",2)=$S(DRGF[53.1:"53.11P",1:"55.07P")
         K DRG,DRGF,%X,%Y,PSGPD Q
         ;
AESCREEN() --
          ;
         ; Output: 0 - Required fields missing and DON'T allow accept
         ;         1 - Required fields found.
         Q:'$G(CHK) 1
         S Y=$P($G(^ORD(101,+$G(^ORD(101,DA(1),10,DA,0)),0)),U) I Y="" Q 0
         I Y="PSJU LM ACCEPT EDIT" Q 1
         Q 0
ACTLOG(PSGORDP,DFN,PSGORD) --
           ;Store 53.1 activity log in local array to be moved to 55
         ;PSGORDP: IEN from 53.1
         ;PSGORD : IEN from 55
         NEW PSGX,PSGXDA,PSGAL531,Q,QQ
         F PSGX=0:0 S PSGX=$O(^PS(53.1,+PSGORDP,"A",PSGX)) Q:'PSGX  D
         . S PSGAL531=$G(^PS(53.1,+PSGORDP,"A",PSGX,0))
         . S QQ=$G(^PS(55,DFN,5,+PSGORD,9,0)) S:QQ="" QQ="^55.09D" F Q=$P(QQ,U,3
          )+1:1 I '$D(^(Q)) S $P(QQ,U,3,4)=Q_U_Q,^(0)=QQ,PSGXDA=Q Q
         . S ^PS(55,DFN,5,+PSGORD,9,PSGXDA,0)=PSGAL531
         . N TXTLN S TXTLN="" F  S TXTLN=$O(^PS(53.1,+PSGORDP,"A",PSGX,1,TXTLN))
           Q:TXTLN=""  D
         .. I TXTLN=0 S ^PS(55,DFN,5,+PSGORD,9,PSGXDA,1,TXTLN)=^PS(53.1,+PSGORDP
          ,"A",PSGX,1,TXTLN) Q
         .. S ^PS(55,DFN,5,+PSGORD,9,PSGXDA,1,TXTLN,0)=^PS(53.1,+PSGORDP,"A",PSG
          X,1,TXTLN,0)
         Q

*****   INDEX OF PSGOEV   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   %X           DDEDIT+7*,DDEDIT+8!
   %Y           DDEDIT+7*,DDEDIT+8!
   CHK          ENSF+5*,ENSF+6,ENSF+9*,ENSF+10,VFY+22,VFY+23,VFY+25*,VFY+26
                VFY+27*,DONE+1,DONE+2,DONE+6!,CHK+5*,CHK+6*,CHK+7*,CHK+8*
                CHK+10*,CHK+11*,CHK+12*,CHK+14*,CHK+16,CHK+17*,CHK+18,CHKM+1
                CHKM+4,CHKM+5,CHKM+6,CHKM+7*,DDCHK+1*,DDCHK+3*,DDCHK+4
                DDEDIT+7,AESCREEN+3
   DA           VFY+33*,VFY+35!*,VFY+39*,VFY+44*,VFY+55*,DONE+6!,AESCREEN+4
   DA(1         VFY+35*,VFY+44*,AESCREEN+4
   DFN          VFY+8,VFY+31,VFY+32,VFY+35,VFY+36,VFY+40,VFY+41,VFY+42,ACTLOG~
                ACTLOG+6,ACTLOG+7,ACTLOG+9,ACTLOG+10
   DIE          VFY+33*,VFY+35!*,VFY+39*,DONE+6!
   DIR          VFY+62!,DONE+3~,CHKM+7~,CONT+1~,CONT+2!
   DIR("A"      DONE+3*,CONT+3*
   DIR("B"      DONE+3*,CONT+3*
   DIR(0        VFY+62*,DONE+3*,CHKM+7*,CONT+3*
   DIRUT        CONT+1~,CONT+2!
   DP           DONE+6!
   DR           VFY+33*,VFY+35!*,VFY+39*,DONE+6!
   DRG          CHK~,CHK+5,CHK+12,CHK+14,CHK+15,DDEDIT+8!
   DRGF         DDCHK+1*,DDCHK+2,DDCHK+3,DDEDIT+2,DDEDIT+4,DDEDIT+7*,DDEDIT+8!
   DT           ALLERGY+5
   DTOUT        CHKM+7~
   DUOUT        CHKM+7~
   DUR          VFY+47~,VFY+48*,VFY+49
   DURON        VFY+47~*,VFY+48
   DUZ          VFY+55,VFY+56
   F            DONE+6!
   FILE55       VFY+31~*,VFY+35
   FILE55N0     VFY+31~*,VFY+32
   LIST         VFY+2~*,VFY+8,VFY+9,VFY+11,VFY+15
   ND           DONE+6!,CHK~,CHK+7,CHK+8,CHK+11
   ND2          CHK~,CHK+10,CHK+11
   OEORD        VFY+31~,VFY+32*,VFY+34,VFY+35
   OOEORD       VFY+31~,VFY+32*
   PND0         VFY+30~*,VFY+31,VFY+32
>> PSGACT       ENSF+11*,ENSF+12*,VFY+63*
   PSGAL        DONE+6!
   PSGAL("C"    VFY+44*
   PSGAL531     ACTLOG+3~,ACTLOG+5*,ACTLOG+7
   PSGALFN      VFY+51!
>> PSGAT        VFY+25
>> PSGCANFL     VFY+63*
>> PSGCOPY      VFY+14
   PSGDDI       ALLERGY+1~,ALLERGY+3*,ALLERGY+4
   PSGDFLG      CHK+13!,CHK+14*
>> PSGDI        CHK+13*,CHK+14*
   PSGDN        VFY+2~*,VFY+6*,VFY+7
>> PSGDT        VFY+55,VFY+56
   PSGODA       DONE+6!
>> PSGODDD(1    VFY+52
>> PSGOEAV      ENSF+2*,ENSF+3
>> PSGOEEF(109  VFY+19*
   PSGOES       ENSF+3,ENSF+9~*,VFY+27~*,CHK+17~*
>> PSGONF       VFY+52
   PSGORD       EN~,ENSF+3,ENSF+5*,ENSF+7,ENSF+11,ENSF+12,VFY+1,VFY+4,VFY+8
                VFY+11,VFY+15,VFY+29,VFY+30,VFY+32,VFY+33,VFY+34,VFY+37,VFY+38
                VFY+39,VFY+40,VFY+41,VFY+42,VFY+44,VFY+45,VFY+46,VFY+47,VFY+49
                VFY+50,VFY+53,VFY+55,VFY+56,VFY+57,VFY+58,VFY+59
                VFY+60,VFY+63,VFY+64,VFY+65,VFY+67,VFY+74,ALLERGY~,ALLERGY+2
                ALLERGY+3,ALLERGY+4,DDCHK+1,ACTLOG~,ACTLOG+6,ACTLOG+7,ACTLOG+9
                ACTLOG+10
   PSGORDP      VFY+33*,VFY+37*,VFY+43,VFY+50,ACTLOG~,ACTLOG+4,ACTLOG+5
                ACTLOG+8,ACTLOG+9,ACTLOG+10
   PSGORDR      VFY+30~*,VFY+31,VFY+32,VFY+34,VFY+35,VFY+36
   PSGORQF      VFY+2~,VFY+15,VFY+16
>> PSGP         ENSF+5,ENSF+11,ENSF+12,VFY+15,VFY+36,VFY+44,VFY+45,VFY+46
                VFY+48,VFY+49,VFY+50,VFY+55,VFY+56,VFY+57,VFY+58,VFY+59,VFY+60
                VFY+63,VFY+64,VFY+74,DONE+5,DDCHK+1
   PSGPD        DDCHK+2*,DDCHK+3,DDEDIT+6,DDEDIT+8!
   PSGPFLG      CHK+13!,CHK+15*
>> PSGRDTX      VFY+43*,VFY+45,VFY+46,VFY+48
   PSGRFD       VFY+51!
   PSGRSD       VFY+51!
   PSGS0XT      ENSF+9~,VFY+24*,VFY+25,VFY+27~,CHK+17~
   PSGS0Y       ENSF+9~,VFY+27~,CHK+17~
>> PSGSCH       ENSF+8,ENSF+9,VFY+23,VFY+24,VFY+26,VFY+27,CHK+16,CHK+17
>> PSGST        VFY+23
   PSGTOL       VFY+55*,DONE+6!
   PSGTOO       VFY+55*,DONE+6!
   PSGUOW       VFY+55*,DONE+6!
   PSGX         ACTLOG+3~,ACTLOG+4*,ACTLOG+5,ACTLOG+8,ACTLOG+9,ACTLOG+10
   PSGXDA       ACTLOG+3~,ACTLOG+6*,ACTLOG+7,ACTLOG+9,ACTLOG+10
>> PSJACEPT     ENSF+10,VFY+18,VFY+20*
   PSJAGYSV     VFY+67!
   PSJALLGY     VFY+15,ALLERGY~
   PSJALLGY(    ALLERGY+7*
   PSJCNT       VFY+2~*,VFY+5*,VFY+6
   PSJCNT1      VFY+2~*,VFY+9*,VFY+10,VFY+11
   PSJCNT2      VFY+2~*,VFY+10*,VFY+11
>> PSJCOM       VFY+1*
   PSJDD        ALLERGY+1~,ALLERGY+4*,ALLERGY+5,ALLERGY+7
   PSJDIS       VFY+2~*,VFY+9,VFY+11*,VFY+14,VFY+15
   PSJDOSE      VFY+2~,DONE+6!
   PSJDOSE("WARN" 
                VFY+18
   PSJDOSE("WARN1" 
                VFY+18
   PSJDSFLG     VFY+2~,VFY+18
>> PSJDSVFY     VFY+15
   PSJFLG       VFY+2~*,VFY+4*,VFY+5,VFY+6
>> PSJHLDFN     VFY+40,VFY+41
>> PSJLMFIN     VFY+14
>> PSJNEWOE     VFY+14
>> PSJORD       VFY+15,VFY+65
>> PSJPRI       DONE+2
   PSJPRIO      VFY+30~,VFY+40*,VFY+42
   PSJSCHED     VFY+30~,VFY+41*,VFY+42
>> PSJSPEED     ENSF+10,VFY+14,VFY+61,VFY+62,DONE+2
>> PSJSTARI     VFY+14,VFY+15
>> PSJSYSL      VFY+55
>> PSJSYSP      CHK+12,CHK+14,DDEDIT+4,DDEDIT+5,DDEDIT+7
>> PSJSYSP0     ENSF+2
>> PSJSYSU      ENSF+2,ENSF+4,ENSF+6,ENSF+11,ENSF+12,VFY+44,VFY+53,VFY+54
                VFY+56,VFY+63,VFY+64,VFY+74,DONE+2
   PSJVAR       DONE+6!
   PSJX         ALLERGY+1~,ALLERGY+5*,ALLERGY+6
   Q            DDEDIT+4*,ACTLOG+3~,ACTLOG+6*
   QQ           ACTLOG+3~,ACTLOG+6*
   QX           VFY+24~
   SDW          VFY+24~
   SWD          VFY+24~
>> TIUDA        DONE+5
   TXTLN        ACTLOG+8~*,ACTLOG+9,ACTLOG+10
   U            VFY+6,VFY+7,VFY+11,VFY+30,VFY+31,VFY+32,VFY+35,VFY+46,VFY+48
                VFY+54,VFY+55,VFY+57,VFY+58,VFY+59,VFY+60,ALLERGY+5,CHK+12
                AESCREEN+4,ACTLOG+6
>> VALMBCK      VFY+64*,DONE+6*
   VND4         VFY+44*,VFY+53,VFY+54*,VFY+56*,VFY+57,VFY+58,VFY+59,VFY+60
                DONE+6!
   X            ENSF+5*,ENSF+9~*,VFY+24~*,VFY+27~*,VFY+52~*,VFY+53,DONE+6!
                CHK+17~*,CHKM+4*,DDEDIT+4*,DDEDIT+5,DDEDIT+6
   XABB         VFY+24~
   Y            ENSF+9~,VFY+27~,DONE+4,CHK+4*,CHK+17~,CHKM+1!,CONT+1~,CONT+5
                DDEDIT+4*,AESCREEN+4*,AESCREEN+5
   ZZND         DONE+6!

Global Variables  ( * Changed  ! Killed)
   ^ORD(101            AESCREEN+4
   ^PS(50.7            CHK+5
   ^PS(53.1            ENSF+3,ENSF+5,ENSF+7,VFY+1,VFY+5,VFY+6,VFY+30,VFY+40
                       VFY+41,VFY+43,ALLERGY+3,ALLERGY+4,ACTLOG+4,ACTLOG+5
                       ACTLOG+8,ACTLOG+9,ACTLOG+10
   ^PS(53.45           DDEDIT+4!*,DDEDIT+5*
   ^PS(55              ENSF+5,ENSF+11,ENSF+12,VFY+40,VFY+41,VFY+44,VFY+49*
                       VFY+55*,VFY+56*,VFY+57*,VFY+58*,VFY+59!,VFY+60!,VFY+63*
                       ACTLOG+6,ACTLOG+7*,ACTLOG+9*,ACTLOG+10*
   ^PSDRUG(            VFY+7,ALLERGY+5
   ^TMP("PSODAOC"      VFY+65*
   ^TMP($J             VFY+9,VFY+11,VFY+15!

Naked Globals
   ^(           ENSF+7,DDEDIT+4,ACTLOG+6
   ^("I"        ALLERGY+5
   ^(0          ENSF+5,CHK+10,ACTLOG+6*
   ^(2          ENSF+7,ALLERGY+5
   ^(4          ENSF+11,VFY+63
   ^(7          VFY+55*

Cache Objects
   NONE

Marked Items
   NONE

Label References
   $$CONT       VFY+18
   ACTLOG       VFY+50
   ALLERGY      VFY+15
   CHK          ENSF+7
   DDCHK        ENSF+6,VFY+22
   DONE         ENSF+5,ENSF+6,ENSF+10,ENSF+11,ENSF+12,VFY+22,VFY+23,VFY+26
   VFY          ENSF+11

External References
   %XY^%RCR            DDEDIT+7
   ^DIE                VFY+33,VFY+35,VFY+39
   ^DIR                VFY+62,DONE+3,CHKM+7,CONT+4
   ^PSGAL5             VFY+44
   NEWUDAL^PSGAL5      VFY+45,VFY+46
   $$DDOK^PSGOE2       CHK+14,DDCHK+3
   $$OIOK^PSGOE2       CHK+15
   $$CHECK^PSGOE8      CHK+12
   ENDRG^PSGOEF1       DDEDIT+6
   EXPOE^PSGOER        VFY+32
   ORSET^PSGOETO1      ENSF+3
   ^PSGOT              VFY+39
   START^PSGOTR        VFY+34
   EN^PSGPEN           VFY+36,VFY+53
   DW^PSGS0            VFY+24
   ENOS^PSGS0          ENSF+9,VFY+27,CHK+17
   ENDDC^PSGSICHK      VFY+15
   ENL^PSGVDS          VFY+55
   NEWJ^PSJADM         VFY+70
   PROFILE^PSJBLDOC    VFY+8
   VFY^PSJCOM          VFY+1
   DOSECHK^PSJDOSE     VFY+3
   SETVAR^PSJDOSE      VFY+18
   EN1^PSJHL2          VFY+36,VFY+64,VFY+74
   NOTIFY^PSJHL4       VFY+42
   $$GETDUR^PSJLIVMD   VFY+48
   REQDT^PSJLIVMD      VFY+38
   $$LASTREN^PSJLMPRI  VFY+32
   SETOC^PSJNEWOC      VFY+67
   IN^PSJOCDS          VFY+15
   CLOZSND^PSJOE       VFY+70
   UNL^PSSLOCK         VFY+36
   MAIN^TIUEDIT        DONE+5
   EN^VALM             ENSF+10,VFY+15
   FULL^VALM1          ENSF+4,VFY+17,CHKM+1
   PAUSE^VALM1         VFY+18,VFY+25

*****   END   *****


PSGOT    * *  58 Lines,  4800 Bytes, Checksum: B24198514
                                                  Jul 01, 2016@13:24:55 page 16
              218 bytes in comments
PSGOT    ;BIR/CML3-TRANSFERS DATA FROM 53.1 TO 55 ;24 SEP 97 / 7:54 AM
         ;;5.0;INPATIENT MEDICATIONS;**13,68,90,110,173,134,161,254,267,257,327*
          *;16 DEC 97;Build 10
         ;
         ; Reference to ^PS(55 supported by DBIA 2191.
         ; Reference to ^PSUHL supported by DBIA 4803.
         ;
START    ; get internal record number, lock record, and write
         S ODA=+PSGORD S:$D(^PS(55,PSGP,0))[0 ^(0)=PSGP,^PS(55,"B",PSGP,PSGP)=""
          ,$P(^PS(55,0),U,3,4)=PSGP_U_($P($G(^PS(55,0)),U,4)+1) F  L +^PS(55,PSG
          P,5,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q
         S ZND=$G(^PS(55,PSGP,5,0)) S:ZND="" ZND="^55.06IA" F DA=$P(ZND,"^",3)+1
          :1 I '$D(^PS(55,PSGP,5,DA)),'$D(^("B",DA)) L +^PS(55,PSGP,5,DA):$S($G(
          DILOCKTM)>0:DILOCKTM,1:3) I  S $P(ZND,"^",3)=DA,$P(ZND,"^",4)=$P(ZND,"
          ^",4)+1,^PS(55,PSGP,5,0)=ZND Q
         L -^PS(55,PSGP,5,0) S ND0=^PS(53.1,ODA,0),$P(ND0,"^",23)=PSJPWD,^PS(55,
          PSGP,5,DA,0)=ND0
         S (ND1,^PS(55,PSGP,5,DA,.2))=$G(^PS(53.1,ODA,.2)),^PS(55,PSGP,5,DA,.3)=
          $G(^PS(53.1,ODA,.3)),(ND2,^PS(55,PSGP,5,DA,2))=^PS(53.1,ODA,2),^PS(55,
          PSGP,5,DA,4)=$G(^PS(53.1,ODA,4)),^PS(55,"AUD",+$P(ND2,"^",4),PSGP,DA)=
          ""
         ;; START NCC REMEDIATION >> 327*RJS
         I $G(PSGPDN)["CLOZ" D
         .M ^PS(55,PSGP,5,DA,"SAND")=^TMP("PSJCOM",$J,ODA,"SAND")
         ;; END NCC REMEDIATION >> 327*RJS
         S X=^PS(55,PSGP,0) I $P(X,"^",7)="" S $P(X,"^",7)=$P($P(ND0,"^",16),"."
          ),$P(X,"^",8)="A",^(0)=X D LOGDFN^PSUHL(PSGP)
         I $P($G(^PS(55,PSGP,5,DA,2)),"^",6)="" S $P(^PS(55,PSGP,5,DA,2),"^",6)=
          $S($G(PSGS0XT)'="":PSGS0XT,$P($G(ZZND),"^",3)'="":$P(ZZND,"^",3),1:"")
          ,$P(^PS(53.1,ODA,2),"^",6)=$P(^PS(55,PSGP,5,DA,2),"^",6)
         F X=6,7,13 I $D(^PS(53.1,ODA,X)) S ^PS(55,PSGP,5,DA,X)=^(X)
         I $D(^PS(53.1,ODA,"DSS")) S ^PS(55,PSGP,5,DA,8)=^("DSS") D CIMOU^PSJIMO
          1(PSGP,DA,"",ODA)
         I $O(^PS(53.1,ODA,1,0)) S (C,X)=0 F  S X=$O(^PS(53.1,ODA,1,X)) Q:'X  S:
          $D(^(X,0)) C=C+1,^PS(55,PSGP,5,DA,1,C,0)=^(0),^PS(55,PSGP,5,DA,1,"B",+
          $P($G(^(0)),U),C)=""
         I $O(^PS(53.1,ODA,1,0)) S ^PS(55,PSGP,5,DA,1,0)="^55.07P^"_C_"^"_C
         F X=3,12 D  S ^PS(55,PSGP,5,DA,X,0)="^55.0"_$S(X=3:8,1:612)_U_CNT_U_CNT
         .S CNT=0 F C=0:0 S C=$O(^PS(53.1,ODA,X,C)) Q:'C  I $D(^(C,0)) S ^PS(55,
          PSGP,5,DA,X,C,0)=^(0),CNT=CNT+1
         S $P(^PS(53.1,ODA,0),"^",19)=DA
         D SETUDINT^PSGSICH1(ODA_"P",DA_"U")
CR       ; set x-refs
         N A
         I $D(^PS(55,PSGP,5.1)),$P(^(5.1),"^",6) S X=$P(^(5.1),"^",6) I $P(ND2,"
          ^",3),$P(ND2,"^",6)'>X S $P(^(5.1),"^",6)=$P(ND2,"^",3)
         S ^PS(55,PSGP,5,"B",+ODA,DA)="",^PS(55,PSGP,5,"AU",$P(ND0,"^",7),+$P(ND
          2,"^",4),DA)=""
         S ^PS(55,PSGP,5,"AUS",+$P(ND2,"^",4),DA)=""
         S ^PS(55,PSGP,5,"C",+ND1,DA)="",^PS(55,"AUE",PSGP,DA)=""
         S ^PS(55,"AUDS",+$P(ND2,"^",2),PSGP,DA)=""
         I $D(^PS(55,PSGP,5,DA,8)) S A=^(8),^PS(55,"AUDC",+$P(ND2,"^",4),+A,PSGP
          ,DA)=""
         I $$PATCH^XPDUTL("PXRM*1.5*12") S X(1)=+$P(ND2,"^",2),X(2)=+$P(ND2,"^",
          4),DA(1)=PSGP D SPSPA^PSJXRFS(.X,.DA,"UD")
         K DIK S DA(1)=PSGP S DIK="^PS(55,"_DA(1)_",5,",DIK(1)=125 D EN1^DIK K D
          IK
         S PSGTOL=2,PSGTOO=1 F PSGUOW=0:0 S PSGUOW=$O(^PS(53.41,2,1,PSGUOW)) Q:'
          PSGUOW  I $D(^(PSGUOW,1,PSGP,1,2,1,+ODA)) K ^(+ODA) D ENL^PSGVDS
DONE     I $D(PSGOE2),PSGOE2]"",$D(^TMP("PSJON",$J,PSGOE2)) S ^(PSGOE2)=DA_"U"
         N PSJTMPTX,PSJOVRMX,PSJTMPLIN
         S PSGODA=ODA,PSGORD=DA_"U"
         S PSGNODE=$G(^PS(55,PSGP,5,DA,0)),PSG25=$P(PSGNODE,"^",25),PSG26=$P(PSG
          NODE,"^",26)
         I PSG25 S X=$S(PSG25["V":"^PS(55,"_PSGP_",""IV"",",PSG25["U"!(PSG25["A"
          ):"^PS(55,"_PSGP_",5,",1:"^PS(53.1,")_+PSG25_","_$E("02",PSG25["V"+1)_
          ")" I $D(@X) S $P(@X,"^",$S(PSG25["V":6,1:26))=DA_"U"
         I $P(PSGNODE,"^",26),$P(PSGNODE,"^",26)'["V",$D(^PS(55,PSGP,5,+$P(PSGNO
          DE,"^",26),0)) S $P(^(0),"^",25)=DA_"U"
         F Q=0:0 S Q=$O(^PS(53.44,Q)) Q:'Q  I $D(^(Q,1,PSGP,+ODA,0)) S $P(^(0),"
          ^",2)=DA
         I $D(^PS(53.1,+ODA,15,0)) S ^PS(55,PSGP,5,DA,15,0)="^55.6135^"_$P($G(^P
          S(53.1,+ODA,15,0)),"^",3)_"^"_$P($G(^PS(53.1,+ODA,15,0)),"^",4) D
         .N LN,LNCNT,SIMSG S SIMSG="Instructions too long. See Order View or BCM
          A for full text."
         .S LNCNT=0,LN=9999 F  S LN=$O(^PS(53.1,+ODA,15,LN),-1) Q:'LN  D
         ..I 'LNCNT,($G(^PS(53.1,+ODA,15,LN,0))="") Q
         ..S ^PS(55,PSGP,5,DA,15,LN,0)=^PS(53.1,+ODA,15,LN,0) S LNCNT=LNCNT+1
         .I LNCNT S $P(^PS(55,PSGP,5,DA,15,0),"^",3,4)=LNCNT_"^"_LNCNT
         .S PSJTMPTX="",PSJOVRMX=0 S TMPLIN=0 F  S TMPLIN=$O(^PS(55,+DFN,5,DA,15
          ,TMPLIN)) Q:'TMPLIN!(PSJOVRMX)  D
         ..S:($L(PSJTMPTX)+$L($G(^PS(55,+DFN,5,DA,15,TMPLIN,0))))>180 PSJOVRMX=1
           Q:$G(PSJOVRMX)  S PSJTMPTX=$G(PSJTMPTX)_$S($G(PSJTMPTX)]"":" ",1:"")_
          $G(^PS(55,+DFN,5,DA,15,TMPLIN,0))
         .S TXT=$S(PSJOVRMX:SIMSG,1:PSJTMPTX)
         .S:($TR(TXT,"^ ")="")!'($D(^PS(55,PSGP,5,DA,15,1))) TXT="" S ^PS(55,PSG
          P,5,DA,6)=TXT S $P(^PS(55,PSGP,5,DA,6),"^",2)=$P(^PS(53.1,+ODA,6),"^",
          2)
         .N LSTLNUM,LSTLNTXT S LSTLNUM=$O(^PS(55,+PSGP,5,+DA,15,""),-1) I LSTLNU
          M>1 S LSTLNTXT=$G(^PS(55,+PSGP,5,+DA,15,LSTLNUM,0)) I $TR(LSTLNTXT," "
          )="" D
         ..K ^PS(55,+PSGP,5,+DA,15,LSTLNUM,0)
         L -^PS(53.1,+ODA) L -^PS(55,PSGP,5,+DA) K CNT,ND,ODA,XX,ZND
         Q
         ;

*****   INDEX OF PSGOT   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   A            CR+1~,CR+7*
>> C            START+13*,START+14,START+16*
   CNT          START+15,START+16*,DONE+19!
>> DA           START+2*,START+3,START+4,START+7,START+10,START+11,START+12
                START+13,START+14,START+15,START+16,START+17,START+18,CR+3,CR+4
                CR+5,CR+6,CR+7,CR+8,DONE,DONE+2,DONE+3,DONE+4,DONE+5,DONE+6
                DONE+7,DONE+11,DONE+12,DONE+13,DONE+14,DONE+16
                DONE+17,DONE+18,DONE+19
>> DA(1         CR+8*,CR+9*
>> DFN          DONE+13,DONE+14
   DIK          CR+9!*
   DIK(1        CR+9*
>> DILOCKTM     START+1,START+2
   LN           DONE+8~,DONE+9*,DONE+10,DONE+11
   LNCNT        DONE+8~,DONE+9*,DONE+10,DONE+11*,DONE+12
   LSTLNTXT     DONE+17~*
   LSTLNUM      DONE+17~*,DONE+18
   ND           DONE+19!
>> ND0          START+3*,START+9,CR+3
>> ND1          START+4*,CR+5
>> ND2          START+4*,CR+2,CR+3,CR+4,CR+6,CR+7,CR+8
   ODA          START+1*,START+3,START+4,START+7,START+10,START+11,START+12
                START+13,START+14,START+16,START+17,START+18,CR+3,CR+10,DONE+2
                DONE+6,DONE+7,DONE+9,DONE+10,DONE+11,DONE+16,DONE+19!
>> PSG25        DONE+3*,DONE+4
>> PSG26        DONE+3*
>> PSGNODE      DONE+3*,DONE+5
>> PSGODA       DONE+2*
>> PSGOE2       DONE
>> PSGORD       START+1,DONE+2*
>> PSGP         START+1,START+2,START+3,START+4,START+7,START+9,START+10
                START+11,START+12,START+13,START+14,START+15,START+16,CR+2,CR+3
                CR+4,CR+5,CR+6,CR+7,CR+8,CR+9,CR+10,DONE+3,DONE+4,DONE+5,DONE+6
                DONE+7,DONE+11,DONE+12,DONE+16,DONE+17,DONE+18
                DONE+19
>> PSGPDN       START+6
>> PSGS0XT      START+10
>> PSGTOL       CR+10*
>> PSGTOO       CR+10*
>> PSGUOW       CR+10*
   PSJOVRMX     DONE+1~,DONE+13*,DONE+14*,DONE+15
>> PSJPWD       START+3
   PSJTMPLIN    DONE+1~
   PSJTMPTX     DONE+1~,DONE+13*,DONE+14*,DONE+15
>> Q            DONE+6*
   SIMSG        DONE+8~*,DONE+15
>> TMPLIN       DONE+13*,DONE+14
>> TXT          DONE+15*,DONE+16*
   U            START+1,START+13,START+15
>> X            START+9*,START+11*,START+13*,START+15*,START+16,CR+2*,CR+8
                DONE+4*
>> X(1          CR+8*
>> X(2          CR+8*
   XX           DONE+19!
   ZND          START+2*,DONE+19!
>> ZZND         START+10

Global Variables  ( * Changed  ! Killed)
   ^PS(53.1            START+3,START+4,START+10*,START+11,START+12,START+13
                       START+14,START+16,START+17*,DONE+7,DONE+9,DONE+10
                       DONE+11,DONE+16,DONE+19
   ^PS(53.41           CR+10
   ^PS(53.44           DONE+6
   ^PS(55              START+1*,START+2*,START+3*,START+4*,START+7*,START+9
                       START+10*,START+11*,START+12*,START+13*,START+14*
                       START+15*,START+16*,CR+2,CR+3*,CR+4*,CR+5*,CR+6*,CR+7*
                       DONE+3,DONE+5,DONE+7*,DONE+11*,DONE+12*,DONE+13,DONE+14
                       DONE+16*,DONE+17
                       DONE+18!,DONE+19
   ^TMP("PSJCOM"       START+7
   ^TMP("PSJON"        DONE

Naked Globals
   ^(           START+11,START+13,START+16,CR+10!,DONE*,DONE+6
   ^("B"        START+2
   ^("DSS"      START+12
   ^(0          START+1*,START+9*,START+13,START+16,DONE+5*,DONE+6*
   ^(5.1        CR+2*
   ^(8          CR+7

Cache Objects
   NONE

Marked Items
   NONE

Label References
   NONE

External References
   EN1^DIK             CR+9
   SETUDINT^PSGSICH1   START+18
   ENL^PSGVDS          CR+10
   CIMOU^PSJIMO1       START+12
   SPSPA^PSJXRFS       CR+8
   LOGDFN^PSUHL        START+9
   $$PATCH^XPDUTL      CR+8

*****   END   *****


PSGPEN   * *  84 Lines,  5952 Bytes, Checksum: B41329909
                                                  Jul 01, 2016@13:24:55 page 17
              578 bytes in comments
PSGPEN   ;BIR/CML3-FIND DEFAULT FOR PRE-EXCHANGE NEEDS ;03 Feb 99 / 9:13 AM
         ;;5.0;INPATIENT MEDICATIONS ;**30,37,50,58,115,110,127,129,327**;16 DEC
           97;Build 10
         ;
         ; References to ^PSD(58.8 supported by DBIA #2283.
         ; References to ^PSI(58.1 supported by DBIA #2284.
         ; Reference to ^PS(55 is supported by DBIA #2191.
         ; Reference to ^PSDRUG is supported by DBIA #2192.
         ; Reference to ^PS(59.7 is supported by DBIA #2181.
         ;
EN(PSGPENO) --
          ;
         S PSGPENO=+PSGPENO
         N PSJSITE,PSJPRN S PSJSITE=0,PSJSITE=$O(^PS(59.7,PSJSITE)) I $P($G(^(PS
          JSITE,26)),U,5)=1 S PSJPRN=1
         D NOW^%DTC S PSGDT=%,DT=$$DT^XLFDT,PSGPEN="" S ND=$G(^PS(55,PSGP,5,PSGP
          ENO,0))
         S PSGPENWS=0 I PSJPWD F Q=0:0 S Q=$O(^PS(55,PSGP,5,PSGPENO,1,Q)) Q:'Q  
          S ND=$G(^(Q,0)) I ND,'$P(ND,"^",3),($D(^PSI(58.1,"D",+ND,PSJPWD))!$D(^
          PSD(58.8,"D",+ND,PSJPWD))) S PSGPENWS=1 Q
         I PSGPENWS F  S Q=$O(^PS(55,PSGP,5,PSGPENO,1,Q)) Q:'Q  S ND=$G(^(Q,0)) 
          I ND,'$P(ND,"^",3) S:'$D(^PSI(58.1,"D",+ND,PSJPWD))&'$D(^PSD(58.8,"D",
          +ND,PSJPWD)) PSGPENWS=0 Q:'PSGPENWS  S $P(PSGPENWS,"^",2)=1
         I PSGPENWS W !!,"The dispense drug",$E("s",$P(PSGPENWS,"^",2))," for th
          is order ",$S($P(PSGPENWS,"^",2):"are",1:"is a")," WARD STOCK item",$E
          ("s",$P(PSGPENWS,"^",2)),"." S PSGPEN=0
         I 'PSGPENWS,PSJPWD S WG=+$O(^PS(57.5,"AB",PSJPWD,0)),PSGPLS=$P($G(^PS(5
          5,PSGP,5,PSGPENO,2)),"^",2) I PSGPLS D
         .S PSGPLF=$O(^PS(53.5,"AB",WG,PSGDT))
         .N RNDT,PSJRNOS S RNDT=$$LASTREN^PSJLMPRI(PSGP,$S($G(PSJORD)["P":PSJORD
          ,1:"")),PSJRNOS=$P(RNDT,"^",4) I PSJRNOS,'$G(PSJREN) S PSGPLS=PSJRNOS
         .I $G(PSJREN),$G(PSJORD)["U" S PSJRNOS=$P(^PS(55,PSGP,5,+PSJORD,2),"^",
          4) S PSGPLS=$S(PSJRNOS>PSGDT:PSJRNOS,1:$$DATE2^PSJUTL2(PSGDT))
         .D:'PSGPLF GF I PSGPLF S PSGPLO=PSGPENO D NCE,^PSGPL0 S:PSGPLC'<0 PSGPE
          N=PSGPLC
         I $G(PSGPRIO)="DONE" S PSGPEN=0
         ;
UPDD     ;
         N DIR S DIR(0)="NOA^0:9999:0",DIR("A")="Pre-Exchange DOSES: ",DIR("?")=
          "^D DH^PSGPEN" S:PSGPEN]"" DIR("B")=PSGPEN W ! D ^DIR G:'Y DONE S PSGY
          =+Y W !!,"...updating dispense drug(s)..."
         F FQ=0:0 S FQ=$O(^PS(55,PSGP,5,PSGPENO,1,FQ)) Q:'FQ  S ND=$G(^(FQ,0)),$
          P(^(0),"^",9)="" I ND,'$P(ND,"^",3) D DD
         ;
DONE     ;
         ;; START NCC REMEDIATION >> 327*RJS
         N PSGDN
         S PSGDN=0,PSGDN=$O(PSJXDOX("DD",PSGDN))
         ;I $D(^PSDRUG("ACLOZ",+PSGDN)) D PSJFILE^PSJCLOZ(DFN),INPSND^YSCLTST5
         ;; END NCC REMEDIATION >> 327*RJS
         I $P(PSJSYSW0,"^",29)="",$$DEFON^PSGPER1 S $P(PSJSYSW0,"^",29)=0
         K PSGID,PSGMAR,PSGOD,PSGPLC,PSGPLF,PSGPLO,PSGPLS,PSGPLUD,WG S:$G(PSJREN
          ) DUOUT=0 Q
         ;
NCE      ;
         W !!,"The next cart exchange is ",$$ENDTC^PSGMI(PSGPLF),! Q
         ;
GF       ;
         S QQ=0 F Q=0:0 S Q=$O(^PS(53.5,"AB",WG,Q)) Q:'Q  S QQ=Q
         I QQ S QQ=$O(^PS(53.5,"AB",WG,QQ,0)) I QQ,$D(^PS(53.5,QQ,0)) S QQ=$P(^(
          0),"^",4) I QQ>PSGDT S PSGPLF=QQ
         Q
         ;
DD       ;
         N DA S DRG=$S($P(ND,"^")="":"NOT FOUND",'$D(^PSDRUG(+ND,0)):"NOT FOUND 
          ("_$P(ND,"^")_")",$P(^(0),"^")]"":$P(^(0),"^"),1:$P(ND,"^")_";PSDRUG("
          ),UD=$S('$P(ND,"^",2):1,1:$P(ND,"^",2))
         W !,"...",DRG,?45,"U/D: ",UD,"..."
         S PSGDA=PSGY I 'PSGPENWS,ND,PSJPWD,($D(^PSI(58.1,"D",+ND,PSJPWD))!$D(^P
          SD(58.8,"D",+ND,PSJPWD))) D PSGPENWS Q:'PSGDA
         K DA,DR S PSGDA=$S(UD#1:(PSGDA*((UD\1)+1)),1:PSGDA*UD)
         S DIE="^PS(55,"_PSGP_",5,"_PSGPENO_",1,",DA(2)=PSGP,DA(1)=PSGPENO,DA=FQ
          ,DR=".09////"_PSGDA D ^DIE
         S PSGPXN=$G(PSGPXN)
         D:'PSGPXN
         .D NOW^%DTC L +^PS(53.4,0):0 S ND=$G(^PS(53.4,0)) S:ND="" ND="PRE-EXCHA
          NGE NEEDS^53.4P" F PSGPXN=$P(ND,"^",3)+1:1 I '$D(^PS(53.4,PSGPXN)) L +
          ^PS(53.4,PSGPXN):0 I  S ^PS(53.4,0)=$P(ND,"^",1,2)_"^"_PSGPXN_"^"_($P(
          ND,"^",4)+1) L -^PS(53.4,0) Q
         .S ^PS(53.4,PSGPXN,0)=DUZ_"^"_%,^PS(53.4,"B",DUZ,PSGPXN)="",^PS(53.4,"A
          UD",DUZ,%,PSGPXN)="" L -^PS(53.4,PSGPXN) Q
         I $D(^PS(53.4,PSGPXN,1,PSGP,1,PSGPENO,1,FQ,0)) S $P(^(0),"^",2)=$P(^(0)
          ,"^",2)+PSGDA Q
         ; naked reference below refers to line above
         S ^(0)=FQ_"^"_PSGDA I $D(^PS(53.4,PSGPXN,1,PSGP,1,PSGPENO,1,0)) S $P(^(
          0),"^",3,4)=FQ_"^"_($P(^(0),"^",4)+1) Q
         ; naked reference below refers to line above
         S ^(0)="^53.401101A^"_FQ_"^1" Q:$D(^PS(53.4,PSGPXN,1,PSGP,1,PSGPENO,0))
            S ^(0)=PSGPENO
         I $D(^PS(53.4,PSGPXN,1,PSGP,1,0)) S $P(^(0),"^",3,4)=PSGPENO_"^"_($P(^(
          0),"^",4)+1) Q
         ; naked reference below is from line above
         S ^(0)="^53.4011A^"_PSGPENO_"^1" Q:$D(^PS(53.4,PSGPXN,1,PSGP,0))  S ^(0
          )=PSGP
         I $D(^PS(53.4,PSGPXN,1,0)) S $P(^(0),"^",3,4)=PSGP_"^"_($P(^(0),"^",4)+
          1) Q
         ; naked reference below is from line above
         S ^(0)="^53.401PA^"_PSGP_"^1" Q
         ;
DH       ;
         W !!?2,"Enter a number from 0 to 9999, 0 decimal digits."
         W !!?2,"Enter the number DOSES needed for this order until the next car
          t exchange.",!,"This will be the number of times the order will be adm
          inistered to the patient",!,"from the start of the order until the nex
          t cart exchange."
         W !!?2,"PLEASE NOTE that this is DOSES, and NOT UNITS.  The doses enter
          ed will be",!,"converted to units for each dispense drug of this order
          , as each dispense drug",!,"may have a different units per dose." Q
         ;
PSGPENWS ;
         W !,"This dispense drug is a WARD STOCK item."
         W !,"Would you like to:",!?3,"1 - Enter 0 (no) doses needed for this di
          spense drug.",!?3,"2 - Enter ",PSGDA," doses needed for this dispense 
          drug.",!?3,"3 - Enter another amount as the doses needed for this disp
          ense drug."
         K DIR S DIR(0)="SA^1:0 (no) doses;2:"_PSGDA_" doses;3:another amount",D
          IR("A")="Select ACTION: ",DIR("?")="^D WH^PSGPEN" W ! D ^DIR I Y=1!'Y 
          S PSGDA=0 Q
         Q:Y=2  K DIR S DIR(0)="NA^0:9999:0",DIR("A")="Pre-Exchange DOSES for th
          is dispense drug: ",DIR("?")="^D WDH^PSGPEN" W ! D ^DIR S PSGDA=+Y Q
         ;
WH       ;
         S Q="This dispense drug ("_DRG_") is a ward stock item.  Select:"
         W !! F Q1=1:1:$L(Q," ") S Q2=$P(Q," ",Q1) W:$X+$L(Q2)>78 ! W Q2," "
         W !?3,"1 to enter 0 (no) pre-exchange doses for this dispense drug.",!?
          3,"2 to enter ",PSGDA," doses for this dispense drug.",!?3,"3 to enter
           another amount for this dispense drug." Q
         ;
WDH      ;
         W !!?2,"Enter a number from 0 to 9999, 0 decimal digits.  If you enter 
          an '^' to exit",!,"NO pre-exchange doses will be entered for this disp
          ense drug." Q

*****   INDEX OF PSGPEN   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
>> %            EN+3,DD+9
   DA           DD+1~,DD+4!,DD+5*
   DA(1         DD+5*
   DA(2         DD+5*
>> DIE          DD+5*
   DIR          UPDD+1~,PSGPENWS+3!,PSGPENWS+4!
   DIR("?"      UPDD+1*,PSGPENWS+3*,PSGPENWS+4*
   DIR("A"      UPDD+1*,PSGPENWS+3*,PSGPENWS+4*
   DIR("B"      UPDD+1*
   DIR(0        UPDD+1*,PSGPENWS+3*,PSGPENWS+4*
   DR           DD+4!,DD+5*
>> DRG          DD+1*,DD+2,WH+1
   DT           EN+3*
>> DUOUT        DONE+7*
   DUZ          DD+9
>> FQ           UPDD+2*,DD+5,DD+10,DD+12,DD+14
>> ND           EN+3*,EN+4*,EN+5*,UPDD+2*,DD+1,DD+3,DD+8*
>> PSGDA        DD+3*,DD+4*,DD+5,DD+10,DD+12,PSGPENWS+2,PSGPENWS+3*,PSGPENWS+4*
                WH+3
   PSGDN        DONE+2~,DONE+3*
>> PSGDT        EN+3*,EN+8,EN+10,GF+2
   PSGID        DONE+7!
   PSGMAR       DONE+7!
   PSGOD        DONE+7!
>> PSGP         EN+3,EN+4,EN+5,EN+7,EN+9,EN+10,UPDD+2,DD+5,DD+10,DD+12,DD+14
                DD+15,DD+17,DD+18,DD+20
>> PSGPEN       EN+3*,EN+6*,EN+11*,EN+12*,UPDD+1
   PSGPENO      EN~,EN+1*,EN+3,EN+4,EN+5,EN+7,EN+11,UPDD+2,DD+5,DD+10,DD+12
                DD+14,DD+15,DD+17
>> PSGPENWS     EN+4*,EN+5*,EN+6,EN+7,DD+3
   PSGPLC       EN+11,DONE+7!
   PSGPLF       EN+8*,EN+11,DONE+7!,NCE+1,GF+2*
   PSGPLO       EN+11*,DONE+7!
   PSGPLS       EN+7*,EN+9*,EN+10*,DONE+7!
   PSGPLUD      DONE+7!
>> PSGPRIO      EN+12
>> PSGPXN       DD+6*,DD+7,DD+8*,DD+9,DD+10,DD+12,DD+14,DD+15,DD+17,DD+18
>> PSGY         UPDD+1*,DD+3
>> PSJORD       EN+9,EN+10
   PSJPRN       EN+2~*
>> PSJPWD       EN+4,EN+5,EN+7,DD+3
>> PSJREN       EN+9,EN+10,DONE+7
   PSJRNOS      EN+9~*,EN+10*
   PSJSITE      EN+2~*
>> PSJSYSW0     DONE+6*
>> PSJXDOX("DD" DONE+3
>> Q            EN+4*,EN+5*,GF+1*,WH+1*,WH+2
>> Q1           WH+2*
>> Q2           WH+2*
>> QQ           GF+1*,GF+2*
   RNDT         EN+9~*
   U            EN+2
>> UD           DD+1*,DD+2,DD+4
   WG           EN+7*,EN+8,DONE+7!,GF+1,GF+2
>> Y            UPDD+1,PSGPENWS+3,PSGPENWS+4

Global Variables  ( * Changed  ! Killed)
   ^PS(53.4            DD+8*,DD+9*,DD+10,DD+12,DD+14,DD+15,DD+17,DD+18
   ^PS(53.5            EN+8,GF+1,GF+2
   ^PS(55              EN+3,EN+4,EN+5,EN+7,EN+10,UPDD+2
   ^PS(57.5            EN+7
   ^PS(59.7            EN+2
   ^PSD(58.8           EN+4,EN+5,DD+3
   ^PSDRUG(            DD+1
   ^PSI(58.1           EN+4,EN+5,DD+3

Naked Globals
   ^(           EN+2,EN+4,EN+5,UPDD+2
   ^(0          UPDD+2*,GF+2,DD+1,DD+10*,DD+12*,DD+14*,DD+15*,DD+17*,DD+18*
                DD+20*

Cache Objects
   NONE

Marked Items
   NONE

Label References
   DD           UPDD+2
   DONE         UPDD+1
   GF           EN+11
   NCE          EN+11
   PSGPENWS     DD+3

External References
   NOW^%DTC            EN+3,DD+8
   ^DIE                DD+5
   ^DIR                UPDD+1,PSGPENWS+3,PSGPENWS+4
   $$ENDTC^PSGMI       NCE+1
   $$DEFON^PSGPER1     DONE+6
   ^PSGPL0             EN+11
   $$LASTREN^PSJLMPRI  EN+9
   $$DATE2^PSJUTL2     EN+10
   $$DT^XLFDT          EN+3

*****   END   *****


PSJCLOLS * *  35 Lines,  2642 Bytes, Checksum: B11327318
                                                  Jul 01, 2016@13:24:55 page 18
              204 bytes in comments
PSJCLOLS ;ALB/RTW - LIST INPATIENT CLOZAPINE ORDERS ENTERED BY OVERRIDE ; 03/25/
          2016 10:31
         ;;5.0;INPATIENT PHARMACY;**327**;;Build 10
         ;RTW copied from routine PSOCLOLS and modified for the NCC Clozapine in
          patient pharmacy project
         W !,"Print list of clozapine prescriptions overriding lockout",!
DATE     S %DT="EAX",%DT("A")="Beginning date : " D ^%DT G EXIT:Y<0 S PSOBD=Y
         S %DT("A")="Ending date : " D ^%DT G EXIT:Y<0 S PSOED=Y+.3 I PSOED<PSOB
          D W !!,"Ending date must be after beginning date" G DATE
DEV      S %ZIS("B")="",%ZIS="MQ" D ^%ZIS G EXIT:POP I $E(IOST)'="P" W !,"Select
           a printer " G DEV
         I $D(IO("Q")) G QUE
DQ       ;Entry to report
         W:$Y @IOF D HD I '$O(^PS(53.8,"B",PSOBD)) W !,?5,"NO PRESCRIPTIONS FOUN
          D",@IOF G EXIT
         I $O(^PS(53.8,"B",PSOBD))>PSOED W !,?5,"NO PRESCRIPTIONS FOUND",@IOF G 
          EXIT
         F PSJOD=PSOBD-.1:0 S PSJOD=$O(^PS(53.8,"B",PSJOD)) Q:'PSJOD  Q:PSJOD>PS
          OED  S PSOI=+$O(^(PSJOD,0)) I $D(^PS(53.8,PSOI,0)) S PSJDATA=^(0) D PR
          INT
         W @IOF
EXIT     D ^%ZISC K %DT,PSJDRG,POP,PSJOD,PSOI,PSJDATA,PSJRX,PSJUSR,PSJAPR,PSJREA
          ,PSJCOM,PSJPAT,PSOBD,PSOED,X,J,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK Q
         ;
PRINT    I $Y+9>IOSL W @IOF D HD
         Q:$P(PSJDATA,"^",2)=""!($P(PSJDATA,"^",3)="")!($P(PSJDATA,"^",4)="")!($
          P(PSJDATA,"^",5)="")
         S PSJORD=+$P(PSJDATA,"^",2),PSJUSR=$P(PSJDATA,"^",3),PSJAPR=$P(PSJDATA,
          "^",4),PSJREA=$P(PSJDATA,"^",5),PSJUSR=$P(^VA(200,PSJUSR,0),"^"),PSJAP
          R=$P(^VA(200,PSJAPR,0),"^"),PSJCOM=$P(PSJDATA,"^",6)
         S PSJNUM=0 F  S PSJNUM=$O(^OR(100,PSJORD,4.5,PSJNUM)) Q:'PSJNUM  D
         . I $P(^OR(100,PSJORD,4.5,PSJNUM,0),"^",4)["DRUG" D
         . . S PSJDRG=$P($G(^OR(100,PSJORD,4.5,PSJNUM,1)),"^",1)
         Q:'$D(PSJDRG)
         S PSJORD=$S($D(^OR(100,PSJORD,0)):^(0),1:""),PSJPAT=+$P(PSJORD,"^",2)
         I PSJORD]"" S PSJPAT=$P(^DPT(PSJPAT,0),"^"),PSJDRG=$P(^PSDRUG(PSJDRG,0)
          ,"^")
         W !,?3,"Date : ",$E(PSJOD,4,5),"/",$E(PSJOD,6,7),"/",$E(PSJOD,2,3),?25,
          "ORDER # : ",$S(PSJORD]"":$P(PSJORD,"^"),1:"UNKNOWN"),?45,"Patient : "
          ,$S(PSJORD]"":PSJPAT,1:"UNKNOWN")
         W !,?3,"DRUG : ",$S(PSJORD]"":PSJDRG,1:"UNKNOWN (PRESCRIPTION DELETED)"
          )
         W !,?3,"Entered by : ",PSJUSR,!,?3,"Approved by : ",PSJAPR
         W !,?3,"Lockout Reason : ",$P(^PS(52.54,PSJREA,0),"^")
         W !,?3,"Comments : " I $L(PSJCOM)<65 W PSJCOM,!! Q
         F J=1:1 Q:$P(PSJCOM," ",J,9999)=""  S X=$P(PSJCOM," ",J) W:$L(X)+$X>70 
          !,?14 W X," "
         W !! Q
HD       U IO W !!,?5,"LIST OF ORDERS WRITTEN FOR CLOZAPINE OVERRIDING LOCKOUT",
          !,?10,"FOR THE DATE RANGE ",$E(PSOBD,4,5),"/",$E(PSOBD,6,7),"/",$E(PSO
          BD,2,3)," THROUGH ",$E(PSOED,4,5),"/",$E(PSOED,6,7),"/",$E(PSOED,2,3),
          ! Q
         ;
QUE      ;queue job
         S ZTRTN="DQ^PSJCLOLS",ZTDESC="CLOZAPINE LIST",ZTSAVE("PSOBD")="",ZTSAVE
          ("PSOED")="" D ^%ZTLOAD G EXIT

*****   INDEX OF PSJCLOLS   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   %DT          DATE*,EXIT!
   %DT("A"      DATE*,DATE+1*
>> %ZIS         DEV*
>> %ZIS("B"     DEV*
   IO           HD
   IO("Q"       DEV+1
   IOF          DQ+1,DQ+2,DQ+4,PRINT
   IOSL         PRINT
   IOST         DEV
   J            EXIT!,PRINT+14*
   POP          DEV,EXIT!
   PSJAPR       EXIT!,PRINT+2*,PRINT+11
   PSJCOM       EXIT!,PRINT+2*,PRINT+13,PRINT+14
   PSJDATA      DQ+3*,EXIT!,PRINT+1,PRINT+2
   PSJDRG       EXIT!,PRINT+5*,PRINT+6,PRINT+8*,PRINT+10
>> PSJNUM       PRINT+3*,PRINT+4,PRINT+5
   PSJOD        DQ+3*,EXIT!,PRINT+9
>> PSJORD       PRINT+2*,PRINT+3,PRINT+4,PRINT+5,PRINT+7*,PRINT+8,PRINT+9
                PRINT+10
   PSJPAT       EXIT!,PRINT+7*,PRINT+8*,PRINT+9
   PSJREA       EXIT!,PRINT+2*,PRINT+12
   PSJRX        EXIT!
   PSJUSR       EXIT!,PRINT+2*,PRINT+11
   PSOBD        DATE*,DATE+1,DQ+1,DQ+2,DQ+3,EXIT!,HD
   PSOED        DATE+1*,DQ+2,DQ+3,EXIT!,HD
   PSOI         DQ+3*,EXIT!
   X            EXIT!,PRINT+14*
>> Y            DATE,DATE+1
   ZTDESC       EXIT!,QUE+1*
   ZTIO         EXIT!
   ZTRTN        EXIT!,QUE+1*
   ZTSAVE       EXIT!
   ZTSAVE("PSOBD" 
                QUE+1*
   ZTSAVE("PSOED" 
                QUE+1*
   ZTSK         EXIT!

Global Variables  ( * Changed  ! Killed)
   ^DPT(               PRINT+8
   ^OR(100             PRINT+3,PRINT+4,PRINT+5,PRINT+7
   ^PS(52.54           PRINT+12
   ^PS(53.8            DQ+1,DQ+2,DQ+3
   ^PSDRUG(            PRINT+8
   ^VA(200             PRINT+2

Naked Globals
   ^(           DQ+3
   ^(0          DQ+3,PRINT+7

Cache Objects
   NONE

Marked Items
   NONE

Label References
   DATE         DATE+1
   DEV          DEV
   EXIT         DATE,DATE+1,DEV,DQ+1,DQ+2,QUE+1
   HD           DQ+1,PRINT
   PRINT        DQ+3
   QUE          DEV+1

External References
   ^%DT                DATE,DATE+1
   ^%ZIS               DEV
   ^%ZISC              EXIT
   ^%ZTLOAD            QUE+1

*****   END   *****


PSJCLOZ  * *  165 Lines,  7880 Bytes, Checksum: B72366132
                                                  Jul 01, 2016@13:24:55 page 19
              645 bytes in comments
PSJCLOZ  ; DAL/RJS - INPATIENT CLOZAPINE ORDER CHECK ; 1/8/16 6:50pm
         ;;5.0;INPATIENT MEDICATIONS ;**327**;01 DEC 15;Build 10
         ;
CLOZ(DFN,DRUG) --
          ;
         ; DFN MUST BE SET TO PATIENT IEN
         ; DRUG MUST BE SET TO DRUG IEN
         I '$G(DFN)!('$G(DRUG)) S ANQX=0 Q
         D PROVCHK($G(PSGPR)) Q:ANQX
         N RTN
         S RTN=$P($G(^PSDRUG(DRUG,"CLOZ1")),U)
         D:$L(RTN) ^@RTN
         Q
         ;
PROVCHK(PROV) --
          ;
         N PSJQUIT
         ;
         S (ANQX,PSJQUIT)=0
         I $G(PROV) D
         .I '$L($$DEA^XUSER(,PROV)) D
         ..S (ANQX,PSJQUIT)=1
         ..W !," ",!,"*** Provider must have a DEA# or VA# to write prescription
          s for this drug."
         . Q:PSJQUIT
         .I '$D(^XUSEC("YSCL AUTHORIZED",PROV)) D
         ..S (ANQX,PSJQUIT)=1
         ..W !," ",!,"*** Provider must hold YSCL AUTHORIZED key to write prescr
          iptions for clozapine."
         Q
BEFQUIT  ;
         Q:'$G(QOAA)
         N QODS,QORF,ORMAX,ORCLPAT
         S QODS=$O(^ORD(101.41,"AB","OR GTX DAYS SUPPLY","")) Q:QODS'>0
         S QODS=$O(^ORD(101.41,ORX,6,"D",QODS,"")) Q:QOIEN'>0
         S QODS=$G(^ORD(101.41,ORX,6,QODS,1))
         S QORF=$O(^ORD(101.41,"AB","OR GTX REFILLS","")) Q:QORF'>0
         S QORF=$O(^ORD(101.41,ORX,6,"D",QORF,"")) Q:QOIEN'>0
         S QORF=$G(^ORD(101.41,ORX,6,QORF,1))
         S QORF=QORF+1
         S ORCLPAT=$P(ORYS,U,7)
         S ORMAX=$S(ORYS="M":28,ORYS="B":14,ORYS="W":7,1:90)
         I QORF*QODS>ORMAX D
         .K ORY
         .S ORY=1_U_ORCLOZ
         .W !,?5,"Problem Ordering Clozapine Related Medication"_U_ORCLOZ
         .W !,?5,"*** This patient is only allowed an order with a maximum Days 
          Supply of "_ORMAX_"."
         .W !,?5,"This includes the amounts added by any refills entered in with
           the order also."
         Q
OVERRIDE ;
         I '$G(^XUSEC("PSOLOCKCLOZ",PROV)) D  Q 1
         .N Y
         .W !," ",!,?5,"*** You are not authorized to override Clozapine orders.
          ",!," "
         .K DIR S DIR(0)="E",DIR("A")="Press Return to Continue..." D ^DIR K DIR
           W @IOF
         Q
PSJFILE(DFN) --
          ;
         S PSJCLPAT=DFN
         I $D(ANQDATA) S PSJPROV=$P(ANQDATA,"^",5),PSJ1PH=$P(ANQDATA,"^"),PSJ2PH
          =$P(ANQDATA,"^",2),PSJREASN=$P(ANQDATA,"^",3),PSJREMRK=$P(ANQDATA,"^",
          4) D NOW^%DTC G:$D(^PS(53,8,"B",%)) PSJFILE D
         . I $D(ORO) S PSJPROV=$P(ORO,"^",4),PSJORN=$P(ORO,"^",1),PSJORDER("PSJO
          RN")=PSJORN
         . K DD,DO S DIC="^PS(53.8,",DIC(0)="L",DLAYGO=53.8,X=%
         . D FILE^DICN K DIC,DLAYGO,DD,DO,DA,DR
         . N PS538 S (PS538,DA)=+Y,DIE="^PS(53.8,",DR="1////"_PSJORDER("PSJORN")
          _";3////"_PSJPROV_";2////"_PSJ1PH_";4////"_PSJREASN_";5////"_PSJREMRK_
          ";6////"_PSJ2PH
         . D ^DIE K DIE,DA,DR
         . K ANQDATA,X,Y,%,ANQREM
         . W !,"THE OVERRIDEN ORDER IS COMPLETE",!
         . D ALERT
         Q
ALERT    ; send an alert to the three approving team members
         S XQADATA=PSCLPAT ;
         S PSOLAST4=$E($P($G(^DPT(PSCLPAT,0)),"^",9),6,9)
         S XQAARCH=1
         S XQAFLG="D"
         S XQA(PSJ1PH)="",XQA(PSJ2PH)="",XQA(PSJPROV)=""
         D NOW^%DTC S Y=% D DD^%DT S PSCDATE=Y
         S XQAMSG=$$GET1^DIQ(2,PSCLPAT,.01)_" ("_PSOLAST4_")"_": CLOZAPINE OVERR
          IDE RX PROCESSED  :"_PSCDATE
         S XQAID="PSI"_","_PSCLPAT
         D PHGRP^PSOCLO1 M XQA=XMY D SETUP^XQALERT
         W !!,"OVERRIDE ALERTS HAVE BEEN SENT TO THE APPROVING TEAM MEMBERS",!!
         Q
         ;
READ     ;
         ;W !,"Do you concurr with the requested override for "_CLOZPAT
         S DIR("A")="Do you concurr with the requested override for "_CLOZPAT,DI
          R(0)="Y",DIR("B")="N" D ^DIR G END:$D(DIRUT) K DIR D:'Y!($D(DIRUT)) EN
          D
         Q
END      ;
         K DIRUT,DIROUT,DIR
         Q
         ;
         ;/RBN Begin modifications to comply with SACC standard for routine leng
          th limits
MSG1     ;
         W !!,"Permission to dispense clozapine has been denied. The results of 
          the latest",!
         W "Lab Test drawn in the past 7 days show ANC results but No Matching W
          BC.",!
         W "If you wish to dispense outside the FDA and VA protocol ANC limits,"
          ,!
         W "document your request to Request for Override of Pharmacy Lockout ",
          !
         W "(from VHA Handbook 1160.02) Director of the",!
         W "VA National Clozapine Coordinating Center",!
         W "(Phone: 214-857-0068 Fax: 214-857-0339) for a one-time override perm
          ission.",!
         W !,"No order entered!"
         S ANQX=1
         Q
MSG2     ;
         W !!,"Permission to dispense clozapine has been denied. The results of 
          the latest",!
         W "Lab Test drawn in the past 7 days show No ANC results. If you wish t
          o dispense",!
         W "outside the FDA and VA protocol ANC limits, document your request to
           Request",!
         W "for Override of Pharmacy Lockout (from VHA Handbook 1160.02) Directo
          r of the",!
         W "VA National Clozapine Coordinating Center",!
         W "(Phone: 214-857-0068 Fax: 214-857-0339) for a one-time override perm
          ission.",!
         W !,"No order entered!"
         S ANQX=1
         Q
MSG3     ;
         W !,"A CBC/Differential including ANC Must Be Ordered and Monitored on 
          a",!
         W "Daily basis until the ANC above 1000/mm3 with no signs of infection.
          ",!
         W "If ANC is between 1000-1499, therapy can be continued but physician 
          must order",!
         W "lab test three times weekly."
         Q
MSG4     ;
         W !,"Permission to dispense clozapine has been denied. If the results o
          f the latest"
         W !,"Lab Test drawn in the past 7 days show ANC below 1000/mm3 and you 
          wish to"
         W !,"dispense outside the FDA and VA protocol ANC limits, document your
           request to"
         W !,"Request for Override of Pharmacy Lockout (from VHA Handbook 1160.0
          2)"
         W !,"Director of the VA National Clozapine Coordinating Center"
         W !,"(Phone: 214-857-0068 Fax: 214-857-0339) for a one-time override pe
          rmission.",!
         S ANQX=1
         Q
MSG5     ;
         W !!,"Permission to dispense clozapine has been denied. Please contact 
          the"
         W !,"Director of the VA National Clozapine Coordinating Center"
         W !!,"Request for Override of Pharmacy Lockout (from VHA Handbook 1160.
          02)"
         W !,"(Phone: 214-857-0068 Fax: 214-857-0339).",!
         Q
MSG6     ; ; ** START NCC REMEDIATION ** 457 AND PSJ 327/RTW MSG 6 added for new
           critically low ANC levels clozapine override requirements
         W !!,"This clozapine drug may not be dispensed to the patient at this t
          ime based on the available lab tests related to the clozapine treatmen
          t program."
         W !!,"Please contact the NCCC to request an override in order to procee
          d with dispensing this drug. "
         W !!,"Request for Override of Pharmacy Lockout (from VHA Handbook 1160.
          02)"
         W !!,"The  matching ANC counts which caused the lockout are of lab test
           results performed on "
         S ANQX=1,Y=$P(PSOYS,"^",6) X ^DD("DD") W $P(Y,"@")
         W !!,?5,"ANC: "_$P(PSOYS,"^",4),!
         Q
MSG9     ;
         W !,"*** Permission to dispense clozapine has been denied based on the 
          available"
         W !,"    lab tests related to the clozapine treatment program. ***"
         W !!,"For a National Override to dispense at the patient's normal frequ
          ency,"
         W !,"please contact the VA National Clozapine Coordinating Center to co
          ntact"
         W !,"the VA National Clozapine Coordinating Center request an Override 
          of"
         W !,"Pharmacy Lockout (from VHA Handbook 1160.02)"
         W !,"(Phone: 214-857-0068 Fax: 214-857-0339)."
         W !,"A Special Conditions Local Override can be approved for"
         W !,"(1) weather-related conditions, (2) mail order delays of clozapine
          , or"
         W !,"(3) inpatient going on leave. With Provider's documentation of app
          roval,"
         W !,"you may dispense a one-time supply not to exceed 4 days.",!
         Q
         ;
         ;/RBN Begin of modifications for new message for IP 4 day overrride.
MSG10    ;
         W !,"*** Permission to dispense clozapine has been denied based on the 
          available"
         W !,"    lab tests related to the clozapine treatment program. ***"
         W !!,"For a National Override to dispense at the patient's normal frequ
          ency,"
         W !,"please contact the VA National Clozapine Coordinating Center to re
          quest an"
         W !,"Override of Pharmacy Lockout (from VHA Handbook 1160.02) (Phone: 2
          14-857-0068"
         W !,"Fax: 214-857-0339)."
         W !,"A Special Conditions Local Override for Inpatients can be approved
           for an"
         W !,"IP Override Order with Outside Lab Results. With Provider's docume
          ntation of"
         W !,"approval, you may dispense a one-time IP supply not to exceed 4 da
          ys."
         W !,"The ANC from another facility must be recorded in the Progress not
          e/comments"
         W !,"in pharmacy"
         Q
         ;/RBN End of modifications for new message for IP 4 day overrride.
         ; ** END NCC REMEDIATION ** 457 AND PSJ 327/RTW 

*****   INDEX OF PSJCLOZ   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   %            PSJFILE+2,PSJFILE+4,PSJFILE+8!,ALERT+6
   ANQDATA      PSJFILE+2,PSJFILE+8!
   ANQREM       PSJFILE+8!
>> ANQX         CLOZ+3*,CLOZ+4,PROVCHK+3*,PROVCHK+6*,PROVCHK+10*,MSG1+9*
                MSG2+8*,MSG4+7*,MSG6+5*
>> CLOZPAT      READ+2
   DA           PSJFILE+5!,PSJFILE+6*,PSJFILE+7!
   DD           PSJFILE+4!,PSJFILE+5!
   DFN          CLOZ~,CLOZ+3,PSJFILE~,PSJFILE+1
   DIC          PSJFILE+4*,PSJFILE+5!
   DIC(0        PSJFILE+4*
   DIE          PSJFILE+6*,PSJFILE+7!
   DIR          OVERRIDE+4!,READ+2!,END+1!
   DIR("A"      OVERRIDE+4*,READ+2*
   DIR("B"      READ+2*
   DIR(0        OVERRIDE+4*,READ+2*
   DIROUT       END+1!
   DIRUT        READ+2,END+1!
   DLAYGO       PSJFILE+4*,PSJFILE+5!
   DO           PSJFILE+4!,PSJFILE+5!
   DR           PSJFILE+5!,PSJFILE+6*,PSJFILE+7!
   DRUG         CLOZ~,CLOZ+3,CLOZ+6
   IOF          OVERRIDE+4
>> ORCLOZ       BEFQUIT+14,BEFQUIT+15
   ORCLPAT      BEFQUIT+2~,BEFQUIT+10*
   ORMAX        BEFQUIT+2~,BEFQUIT+11*,BEFQUIT+12,BEFQUIT+16
>> ORO          PSJFILE+3
>> ORX          BEFQUIT+4,BEFQUIT+5,BEFQUIT+7,BEFQUIT+8
   ORY          BEFQUIT+13!,BEFQUIT+14*
>> ORYS         BEFQUIT+10,BEFQUIT+11
   PROV         PROVCHK~,PROVCHK+4,PROVCHK+5,PROVCHK+9,OVERRIDE+1
   PS538        PSJFILE+6~*
>> PSCDATE      ALERT+6*,ALERT+7
>> PSCLPAT      ALERT+1,ALERT+2,ALERT+7,ALERT+8
>> PSGPR        CLOZ+4
>> PSJ1PH       PSJFILE+2*,PSJFILE+6,ALERT+5
>> PSJ2PH       PSJFILE+2*,PSJFILE+6,ALERT+5
>> PSJCLPAT     PSJFILE+1*
>> PSJORDER("PSJORN" 
                PSJFILE+3*,PSJFILE+6
>> PSJORN       PSJFILE+3*
>> PSJPROV      PSJFILE+2*,PSJFILE+3*,PSJFILE+6,ALERT+5
   PSJQUIT      PROVCHK+1~,PROVCHK+3*,PROVCHK+6*,PROVCHK+8,PROVCHK+10*
>> PSJREASN     PSJFILE+2*,PSJFILE+6
>> PSJREMRK     PSJFILE+2*,PSJFILE+6
>> PSOLAST4     ALERT+2*,ALERT+7
>> PSOYS        MSG6+5,MSG6+6
>> QOAA         BEFQUIT+1
   QODS         BEFQUIT+2~,BEFQUIT+3*,BEFQUIT+4*,BEFQUIT+5*,BEFQUIT+12
>> QOIEN        BEFQUIT+4,BEFQUIT+7
   QORF         BEFQUIT+2~,BEFQUIT+6*,BEFQUIT+7*,BEFQUIT+8*,BEFQUIT+9*
                BEFQUIT+12
   RTN          CLOZ+5~,CLOZ+6*,CLOZ+7
   U            CLOZ+6,BEFQUIT+10,BEFQUIT+14,BEFQUIT+15
   X            PSJFILE+4*,PSJFILE+8!
>> XMY          ALERT+9
>> XQA          ALERT+9*
>> XQA(         ALERT+5*
>> XQAARCH      ALERT+3*
>> XQADATA      ALERT+1*
>> XQAFLG       ALERT+4*
>> XQAID        ALERT+8*
>> XQAMSG       ALERT+7*
   Y            OVERRIDE+2~,PSJFILE+6,PSJFILE+8!,ALERT+6*,READ+2,MSG6+5*

Global Variables  ( * Changed  ! Killed)
   ^DD("DD"            MSG6+5
   ^DPT(               ALERT+2
   ^ORD(101.41         BEFQUIT+3,BEFQUIT+4,BEFQUIT+5,BEFQUIT+6,BEFQUIT+7
                       BEFQUIT+8
   ^PS(53              PSJFILE+2
   ^PSDRUG(            CLOZ+6
   ^XUSEC("PSOLOCKCLOZ"OVERRIDE+1
   ^XUSEC("YSCL AUTHORIZED"
                       PROVCHK+9

Naked Globals
   NONE

Cache Objects
   NONE

Marked Items
   NONE

Label References
   ALERT        PSJFILE+10
   END          READ+2
   PROVCHK      CLOZ+4
   PSJFILE      PSJFILE+2

External References
   DD^%DT              ALERT+6
   NOW^%DTC            PSJFILE+2,ALERT+6
   ^@(                 CLOZ+7
   FILE^DICN           PSJFILE+5
   ^DIE                PSJFILE+7
   $$GET1^DIQ          ALERT+7
   ^DIR                OVERRIDE+4,READ+2
   PHGRP^PSOCLO1       ALERT+9
   SETUP^XQALERT       ALERT+9
   $$DEA^XUSER         PROVCHK+5

*****   END   *****


PSJCOM   * *  125 Lines,  7271 Bytes, Checksum: B43612843
                                                  Jul 01, 2016@13:24:55 page 20
              1044 bytes in comments
PSJCOM   ;BIR/CML3-FINISH COMPLEX UNIT DOSE ORDERS ENTERED THROUGH OE/RR ;02 Feb
           2001  12:20 PM
         ;;5.0;INPATIENT MEDICATIONS;**110,186,267,281,327**;16 DEC 97;Build 10
         ;
         ; Reference to ^VALM1 is supported by DBIA 10116.
         ; Reference to ^PS(55 is supported by DBIA 2191.
         ; Reference to ^%DTC is supported by DBIA 10000.
         ; Reference to ^%RCR is supported by DBIA 10022.
         ; Reference to ^DIR is supported by DBIA 10026.
         ; Reference to ^TIUEDIT is supported by DBIA 2410.
         ; Reference to ^TMP("PSODAOC",$J supported by DBIA 6071.
         ;
UPD      ;
         Q:'PSJCOM
         M ^TMP("PSJCOM",$J,+PSGORD)=^PS(53.1,+PSGORD)
         I PSGST="",(PSGSCH="NOW"!(PSGSCH="ONCE")) S PSGST="O"
         S $P(^TMP("PSJCOM",$J,+PSGORD,0),"^",9)="N",$P(^(0),"^",4)="U",$P(^(0),
          "^",7)=PSGST,$P(^TMP("PSJCOM",$J,+PSGORD,2),"^",2)=PSGSD,$P(^(2),"^",4
          )=PSGFD
         I $D(PSGSI),$P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" S ^TMP("PSJCOM",$J,+P
          SGORD,6)=PSGSI
         I $D(PSGSI),$P($G(^PS(53.1,+PSGORD,0)),U,24)="R" S $P(^TMP("PSJCOM",$J,
          +PSGORD,6),U)=$P(PSGSI,U) I $P(PSGSI,U)="" S $P(^TMP("PSJCOM",$J,+PSGO
          RD,6),U,2)=""
         S:$D(PSGSCH) $P(^TMP("PSJCOM",$J,+PSGORD,2),"^")=PSGSCH
         I PSGSM,PSGOHSM'=PSGHSM S $P(^TMP("PSJCOM",$J,+PSGORD,0),"^",5)=PSGSM,$
          P(^TMP("PSJCOM",$J,+PSGORD,0),"^",6)=PSGHSM
         W "."
         S PSGOEEWF="^TMP(""PSJCOM"",$J,+PSGORD,"
         F Q=1,3 K @(PSGOEEWF_Q_")") S %X="^PS(53.45,"_PSJSYSP_","_$S(Q=1:2,1:1)
          _",",%Y=PSGOEEWF_Q_"," K @(PSGOEEWF_Q_")") D %XY^%RCR W "."  ;MOU-0100
          -30945
         S PSGND=$G(^TMP("PSJCOM",$J,+PSGORD,0)),X=$P(PSGND,U,24)
         S PSJOWALL=+$G(^PS(55,PSGP,5.1))
         I $S(X="R":1,+$G(^PS(55,PSGP,5.1))>PSGDT:0,1:X'="E") S X=$G(^TMP("PSJCO
          M",$J,+PSGORD,2)) D ENWALL^PSGNE3(+$P(X,U,2),+$P(X,U,4),PSGP)
         S $P(^TMP("PSJCOM",$J,+PSGORD,.2),U,2)=PSGDO,$P(^TMP("PSJCOM",$J,+PSGOR
          D,2),U,5)=PSGAT S:$G(PSGS0XT) $P(^(2),U,6)=PSGS0XT
         I 'PSGOEAV D NEWNVAL(PSGORD,$S(+PSJSYSU=3:22005,1:22000))
         I $D(^PS(53.45,DUZ,5,1,0)) D FILESI^PSJBCMA5(PSGP,PSGORD) N SIARRAY S S
          IARRAY="" D NEWNVAL^PSGAL5(PSGORD,6000,"SPECIAL INSTRUCTIONS",,.SIARRA
          Y)
         I PSGOEAV,+PSJSYSU=3 D VFY Q
         I PSGOEAV,$G(PSJRNF) D VFY
         Q
VFY      ; change status, move to 55, and change label record
         Q:'PSJCOM
         S ^TMP("PSODAOC",$J,"IP IEN")=PSGORD
         D SETOC^PSJNEWOC(PSGORD)
         I '$D(^TMP("PSJCOM",$J,+PSGORD)) M ^TMP("PSJCOM",$J,+PSGORD)=^PS(53.1,+
          PSGORD)
         NEW PSJDOSE,PSJDSFLG
         D DOSECHK^PSJDOSE
         I +$G(PSJDSFLG) D SETVAR^PSJDOSE W !!,PSJDOSE("WARN"),!,PSJDOSE("WARN1"
          ) I '$$CONT() W !,"...order was not verified..." D PAUSE^VALM1 D  Q:'$
          G(PSJACEPT)
         . S PSGOEEF(109)=1
         . S PSJACEPT=0
         D DDCHK G:CHK DONE
         ;; START NCC REMEDIATION >> 327*RJS
         I $G(PSGPDN)["CLOZ" D
         .S DIR(0)="N^12.5:3000:1",DIR("A")="CLOZAPINE dosage (mg/day) ? " D ^DI
          R K DIR S:$D(DIRUT) CHK=1 G DONE:$G(CHK)
         .;S PSGTDD=X
         .S ^TMP("PSJCOM",$J,+PSGORD,"SAND")=X
ZZ       W !,"...a few moments, please..."
         I PSGORD["P" D
         . S PSGORDP=PSGORD ;Used in ACTLOG to update activity log in ^TMP
         . I '$D(^TMP("PSJCOM2",$J,+PSGORD)) D  Q
         .. NEW PSGX S PSGX=$G(^TMP("PSJCOM",$J,+PSGORD,2.5)),PSGRSD=$P(PSGX,U),
          PSGRFD=$P(PSGX,U,3)
         .. S $P(^TMP("PSJCOM",$J,+PSGORD,0),"^",9)="A" W "." ;D ^PSGOT
         .  NEW PSGX S PSGX=$G(^TMP("PSJCOM2",$J,+PSGORD,2.5)),PSGRSD=$P(PSGX,U)
          ,PSGRFD=$P(PSGX,U,3)
         .  S $P(^TMP("PSJCOM2",$J,+PSGORD,0),"^",9)="A" W "." ;D ^PSGOT
         D NEWNVAL(+PSGORD,(PSJSYSU*10+22000)) W "."
         S VND4=$S('$D(^TMP("PSJCOM2",$J,+PSGORD)):$G(^TMP("PSJCOM",$J,+PSGORD,4
          )),1:$G(^TMP("PSJCOM2",$J,+PSGORD,4)))
         I $G(PSGRSD) D
         . S PSGRSD=$$ENDTC^PSGMI(PSGRSD) D NEWNVAL(PSGORD,6090,"Requested Start
           Date",PSGRSD)
         . S PSGRFD=$$ENDTC^PSGMI(PSGRFD) D NEWNVAL(PSGORD,6090,"Requested Stop 
          Date",PSGRFD)
         N DUR,DURORD S DURON=$S($G(ON)&($G(PSGORD)["U"):ON,$G(PSGORD):PSGORD,1:
          "") Q:'DURON  D
         . S DUR=$S($P($G(PSGRDTX),U,2)]"":$P($G(PSGRDTX),U,2),1:$$GETDUR^PSJLIV
          MD(PSGP,+DURON,$S($G(DURON)["P":"P",$G(DURON)["V":"IV",1:5),1),1:"")
         I DUR]"" S $P(^TMP("PSJCOM2",$J,+PSGORD,2.5),"^",2)=DUR
         ;D:$D(PSGORDP) ACTLOG(PSGORDP,PSGP,PSGORD)
         K PSGRSD,PSGRFD,PSGALFN
         NEW X S X=0 I $G(PSGONF),(+$G(PSGODDD(1))'<+$G(PSGONF)) S X=1
         I +PSJSYSU=3,PSGORD'["O",$S(X:0,'$P(VND4,"^",16):1,1:$P(VND4,"^",15)) ;
          D EN^PSGPEN(+PSGORD)
         S:'$P(VND4,U,+PSJSYSU=3+9) $P(VND4,U,+PSJSYSU=3+9)=+$P(VND4,U,+PSJSYSU=
          3+9)
         S:$P(VND4,"^",15)&'$P(VND4,"^",16) $P(VND4,"^",15)="" S:$P(VND4,"^",18)
          &'$P(VND4,"^",19) $P(VND4,"^",18)="" S:$P(VND4,"^",22)&'$P(VND4,"^",23
          ) $P(VND4,"^",22)=""
         S $P(VND4,"^",PSJSYSU,PSJSYSU+1)=DUZ_"^"_PSGDT
         S:'$D(^TMP("PSJCOM2",$J,+PSGORD)) ^TMP("PSJCOM",$J,+PSGORD,4)=VND4 S:$D
          (^TMP("PSJCOM2",$J,+PSGORD)) ^TMP("PSJCOM2",$J,+PSGORD,4)=VND4
         W:'$D(PSJSPEED) ! W !,"ORDER VERIFIED.",!
         I '$D(PSJSPEED) K DIR S DIR(0)="E" D ^DIR K DIR
         S VALMBCK="Q"
         S ^TMP("PSJCOM",$J)="A" S:$D(^TMP("PSJCOM2",$J,+PSGORD)) ^TMP("PSJCOM2"
          ,$J)="A"
         ;
DONE     ;
         W:CHK !!,"...order NOT verified..."
         I '$D(PSJSPEED),'CHK,+PSJSYSU=3,$G(PSJPRI)="D" D
         .N DIR W ! S DIR(0)="S^Y:Yes;N:No",DIR("A")="Do you want to enter a Pro
          gress Note",DIR("B")="No" D ^DIR
         .Q:Y="N"
         .D MAIN^TIUEDIT(3,.TIUDA,PSGP,"","","","",1)
         S VALMBCK="Q" K CHK,DA,DIE,F,DP,DR,ND,PSGAL,PSGODA,PSJDOSE,PSJVAR,VND4,
          X,%X,%Y,Q,QQ Q
         ;
DDCHK    ; dispense drug check
         S DRGF=$S('$D(^TMP("PSJCOM2",$J,+PSGORD)):"^TMP(""PSJCOM"","_$J_","_+PS
          GORD_",",1:"^TMP(""PSJCOM2"","_$J_","_+PSGORD_","),CHK=$S('$O(@(DRGF_"
          1,0)")):7,1:0)
         S PSGPD=$G(@(DRGF_".2)"))
         S CHK=$S('$$DDOK^PSGOE2(DRGF_"1,",PSGPD):7,1:0)
         Q:CHK=0
         W $C(7),!!,"This order must have at least one valid, active dispense dr
          ug to be verified."
         ;
CONT()   ;
         NEW DIR,DIRUT,Y
         W ! K DIR,DIRUT
         S DIR(0)="Y",DIR("A")="Would you like to continue verifying the order",
          DIR("B")="No"
         D ^DIR
         Q Y
         ;
NEWNVAL(PSGALORD,PSGALC,PSGFLD,PSGOLD) --
           ;
         ;
         ;Where  PSGALORD = PSGORD (Required)
         ;       PSGALC   = ACTIVITY CODE FROM #53.3 (Required)
         ;       PSGFLD   = FIELD THAT CHANGED (Free text, optional)
         ;       PSGOLD   = THE FIELDS OLD DATA VALUE (Free text, optional)
         ;
         ;N PSGALORD,PSGALC,PSGFLD,PSGOLD
         ;
         ; Create 0 node activity log for order if none exists, and get next ent
          ry number
         I '$D(^TMP("PSJCOM2",$J,+PSGALORD)) D  Q
         . S QQ=$G(^TMP("PSJCOM",$J,+PSGALORD,"A",0)) S:QQ="" QQ="^53.1119D" F Q
          =$P(QQ,"^",3)+1:1 I '$D(^(Q)) S $P(QQ,"^",3,4)=Q_"^"_Q,^(0)=QQ,PSGAL("
          N")=Q Q
         . ;Set up data to be held in activity log record
         . D NOW^%DTC S PSGDT=+$E(%,1,12)
         . I $L($G(PSGOLD))>170 S PSGOLD=$E(PSGOLD,1,167)_"..." ; Use of ... ind
          icates old data field was greater than 170 characters
         . S Q=%_"^"_$S(PSGALC=6010:"AUTO CANCEL",$D(DUZ)[0:"UNKNOWN",DUZ]"":DUZ
          ,1:"UNKNOWN")_"^"_PSGALC_"^"_$S($D(PSGFLD):PSGFLD,1:"")_"^"_$S($D(PSGO
          LD):PSGOLD,1:"")
         . ; Create activity log entry
         . S ^TMP("PSJCOM",$J,+PSGALORD,"A",PSGAL("N"),0)=Q
         S QQ=$G(^TMP("PSJCOM2",$J,+PSGALORD,"A",0)) S:QQ="" QQ="^53.1119D" F Q=
          $P(QQ,"^",3)+1:1 I '$D(^(Q)) S $P(QQ,"^",3,4)=Q_"^"_Q,^(0)=QQ,PSGAL("N
          ")=Q Q
         ;Set up data to be held in activity log record
         D NOW^%DTC S PSGDT=+$E(%,1,12)
         I $L($G(PSGOLD))>170 S PSGOLD=$E(PSGOLD,1,167)_"..." ; Use of ... indic
          ates old data field was greater than 170 characters
         S Q=%_"^"_$S(PSGALC=6010:"AUTO CANCEL",$D(DUZ)[0:"UNKNOWN",DUZ]"":DUZ,1
          :"UNKNOWN")_"^"_PSGALC_"^"_$S($D(PSGFLD):PSGFLD,1:"")_"^"_$S($D(PSGOLD
          ):PSGOLD,1:"")
         ; Create activity log entry
         S ^TMP("PSJCOM2",$J,+PSGALORD,"A",PSGAL("N"),0)=Q
         Q

*****   INDEX OF PSJCOM   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
>> %            NEWNVAL+13,NEWNVAL+15,NEWNVAL+20,NEWNVAL+22
   %X           UPD+11*,DONE+6!
   %Y           UPD+11*,DONE+6!
   CHK          VFY+10,VFY+13*,DONE+1,DONE+2,DONE+6!,DDCHK+1*,DDCHK+3*,DDCHK+4
   DA           DONE+6!
   DIE          DONE+6!
   DIR          VFY+13!,ZZ+25!,DONE+3~,CONT+1~,CONT+2!
   DIR("A"      VFY+13*,DONE+3*,CONT+3*
   DIR("B"      DONE+3*,CONT+3*
   DIR(0        VFY+13*,ZZ+25*,DONE+3*,CONT+3*
   DIRUT        VFY+13,CONT+1~,CONT+2!
   DP           DONE+6!
   DR           DONE+6!
>> DRGF         DDCHK+1*,DDCHK+2,DDCHK+3
   DUR          ZZ+13~,ZZ+14*,ZZ+15
>> DURON        ZZ+13*,ZZ+14
   DURORD       ZZ+13~
   DUZ          UPD+17,ZZ+22,NEWNVAL+15,NEWNVAL+22
   F            DONE+6!
   ND           DONE+6!
>> ON           ZZ+13
   PSGAL        DONE+6!
   PSGAL("N"    NEWNVAL+11*,NEWNVAL+17,NEWNVAL+18*,NEWNVAL+24
   PSGALC       NEWNVAL~,NEWNVAL+15,NEWNVAL+22
   PSGALFN      ZZ+17!
   PSGALORD     NEWNVAL~,NEWNVAL+10,NEWNVAL+11,NEWNVAL+17,NEWNVAL+18,NEWNVAL+24
>> PSGAT        UPD+15
>> PSGDO        UPD+15
>> PSGDT        UPD+14,ZZ+22,NEWNVAL+13*,NEWNVAL+20*
>> PSGFD        UPD+4
   PSGFLD       NEWNVAL~,NEWNVAL+15,NEWNVAL+22
>> PSGHSM       UPD+8
>> PSGND        UPD+12*
   PSGODA       DONE+6!
>> PSGODDD(1    ZZ+18
>> PSGOEAV      UPD+16,UPD+18,UPD+19
>> PSGOEEF(109  VFY+8*
>> PSGOEEWF     UPD+10*,UPD+11
>> PSGOHSM      UPD+8
   PSGOLD       NEWNVAL~,NEWNVAL+14*,NEWNVAL+15,NEWNVAL+21*,NEWNVAL+22
>> PSGONF       ZZ+18
>> PSGORD       UPD+2,UPD+4,UPD+5,UPD+6,UPD+7,UPD+8,UPD+12,UPD+14,UPD+15,UPD+16
                UPD+17,VFY+2,VFY+3,VFY+4,VFY+15,ZZ+1,ZZ+2,ZZ+3,ZZ+4,ZZ+5,ZZ+6
                ZZ+7,ZZ+8,ZZ+9,ZZ+11,ZZ+12,ZZ+13,ZZ+15,ZZ+19,ZZ+23,ZZ+27
                DDCHK+1
>> PSGORDP      ZZ+2*
>> PSGP         UPD+13,UPD+14,UPD+17,ZZ+14,DONE+5
>> PSGPD        DDCHK+2*,DDCHK+3
>> PSGPDN       VFY+12
>> PSGRDTX      ZZ+14
   PSGRFD       ZZ+4*,ZZ+6*,ZZ+12*,ZZ+17!
   PSGRSD       ZZ+4*,ZZ+6*,ZZ+10,ZZ+11*,ZZ+17!
>> PSGS0XT      UPD+15
>> PSGSCH       UPD+3,UPD+7
>> PSGSD        UPD+4
>> PSGSI        UPD+5,UPD+6
>> PSGSM        UPD+8
>> PSGST        UPD+3*,UPD+4
   PSGX         ZZ+4~*,ZZ+6~*
>> PSJACEPT     VFY+7,VFY+9*
>> PSJCOM       UPD+1,VFY+1
   PSJDOSE      VFY+5~,DONE+6!
   PSJDOSE("WARN" 
                VFY+7
   PSJDOSE("WARN1" 
                VFY+7
   PSJDSFLG     VFY+5~,VFY+7
>> PSJOWALL     UPD+13*
>> PSJPRI       DONE+2
>> PSJRNF       UPD+19
>> PSJSPEED     ZZ+24,ZZ+25,DONE+2
>> PSJSYSP      UPD+11
>> PSJSYSU      UPD+16,UPD+18,ZZ+8,ZZ+19,ZZ+20,ZZ+22,DONE+2
   PSJVAR       DONE+6!
   Q            UPD+11*,DONE+6!,NEWNVAL+11*,NEWNVAL+15*,NEWNVAL+17,NEWNVAL+18*
                NEWNVAL+22*,NEWNVAL+24
   QQ           DONE+6!,NEWNVAL+11*,NEWNVAL+18*
   SIARRAY      UPD+17~*
>> TIUDA        DONE+5
   U            UPD+5,UPD+6,UPD+12,UPD+14,UPD+15,ZZ+4,ZZ+6,ZZ+14,ZZ+20
>> VALMBCK      ZZ+26*,DONE+6*
   VND4         ZZ+9*,ZZ+19,ZZ+20*,ZZ+21*,ZZ+22*,ZZ+23,DONE+6!
   X            UPD+12*,UPD+14*,VFY+15,ZZ+18~*,ZZ+19,DONE+6!
   Y            DONE+4,CONT+1~,CONT+5

Global Variables  ( * Changed  ! Killed)
   ^PS(53.1            UPD+2,UPD+5,UPD+6,VFY+4
   ^PS(53.45           UPD+17
   ^PS(55              UPD+13,UPD+14
   ^TMP("PSJCOM"       UPD+2*,UPD+4*,UPD+5*,UPD+6*,UPD+7*,UPD+8*,UPD+12,UPD+14
                       UPD+15*,VFY+4*,VFY+15*,ZZ+4,ZZ+5*,ZZ+9,ZZ+23*,ZZ+27*
                       NEWNVAL+11,NEWNVAL+17*
   ^TMP("PSJCOM2"      ZZ+3,ZZ+6,ZZ+7*,ZZ+9,ZZ+15*,ZZ+23*,ZZ+27*,DDCHK+1
                       NEWNVAL+10,NEWNVAL+18,NEWNVAL+24*
   ^TMP("PSODAOC"      VFY+2*

Naked Globals
   ^(           NEWNVAL+11,NEWNVAL+18
   ^(0          UPD+4*,NEWNVAL+11*,NEWNVAL+18*
   ^(2          UPD+4*,UPD+15*

Cache Objects
   NONE

Marked Items
   NONE

Label References
   $$CONT       VFY+7
   DDCHK        VFY+10
   DONE         VFY+10,VFY+13
   NEWNVAL      UPD+16,ZZ+8,ZZ+11,ZZ+12
   VFY          UPD+18,UPD+19

External References
   NOW^%DTC            NEWNVAL+13,NEWNVAL+20
   %XY^%RCR            UPD+11
   ^DIR                VFY+13,ZZ+25,DONE+3,CONT+4
   NEWNVAL^PSGAL5      UPD+17
   $$ENDTC^PSGMI       ZZ+11,ZZ+12
   ENWALL^PSGNE3       UPD+14
   $$DDOK^PSGOE2       DDCHK+3
   FILESI^PSJBCMA5     UPD+17
   DOSECHK^PSJDOSE     VFY+6
   SETVAR^PSJDOSE      VFY+7
   $$GETDUR^PSJLIVMD   ZZ+14
   SETOC^PSJNEWOC      VFY+3
   MAIN^TIUEDIT        DONE+5
   PAUSE^VALM1         VFY+7

*****   END   *****


PSJOE    * *  251 Lines,  12636 Bytes, Checksum: B114310748
                                                  Jul 01, 2016@13:24:55 page 21
              2044 bytes in comments
PSJOE    ;BIR/MLM - INPATIENT ORDER ENTRY ;23 Jun 98  1:46 PM
         ;;5.0;INPATIENT MEDICATIONS;**7,26,29,33,42,50,56,72,58,85,95,80,110,11
          1,133,140,151,149,181,252,281,327**;16 DEC 97;Build 10
         ;
         ; Reference to ^PS(55 is supported by DBIA #2191.
         ; Reference to EN^VALM is supported by DBIA #10118.
         ; Reference to FULL^VALM1 is supported by DBIA #10116.
         ; Reference to PAUSE^VALM1 is supported by DBIA #10116.
         ; Reference to ^PSSLOCK is supported by DBIA #2789
         ; Reference to ^DPT( is supported by DBIA #10035.
         ; Reference to ^ORCFLAG is supported by DBIA #3620.
         ; Reference to ^SDAMA203 is supported by DBIA #4133.
         ; Reference to ^TMP("PSODAOC" is supported by DBIA #6071.
         ;
EN       ; Start Inpatient LM OE
         N PSJLK,PSJNEWOE,PSJLMCON,PSJPROT,XQORS,VALMEVL D ENCV^PSGSETU,^PSIVXU
         I $D(XQUIT) K XQUIT G DONE
         K PSGVBY,PSJPR S (PSJOL,PSJACOK,PSGOP,PSGNEF,PSGOEAV,PSGPXN)="" L +^PS(
          53.45,PSJSYSP):1 E  D LOCKERR^PSJOE G DONE^PSJOE
         F  S (PSJLMCON,PSGPTMP)=0 D ^PSJP,HK Q:PSGP'>0  S PSJPROT=3,DFN=PSGP D 
          ^PSJAC D  I PSJLK D UL^PSSLOCK(PSGP)
         .K ^TMP("PSJ",$J)
         .S PSJLK=$$L^PSSLOCK(PSGP,1) I 'PSJLK W !,$C(7),$P(PSJLK,U,2) Q
         .K PSJLMPRO D EN^VALM("PSJ LM BRIEF PATIENT INFO")
         .N NXTPT S NXTPT=0 F  Q:$G(NXTPT)  D
         ..K PSGRDTX
         ..I $G(PSJLMCON)!$G(PSJNEWOE) D
         ...S PSJOL=$S(",S,L,"[(","_$G(PSJOL)_","):PSJOL,1:"S")
         ...S PSJLMPRO=1,PSJLMCON=1,PSJNEWOE=0 D EN^VALM("PSJ LM OE")
         ..I $G(PSJNEWOE)!($G(VALMBCK)="Q") S PSJNEWOE=0 Q
         ..I $G(PSJLMCON)&$G(PSJLMPRO)&'$D(^TMP("PSJ",$J)) D  Q
         ...S PSJLMCON=0,PSJLMPRO=0 D EN^VALM("PSJ LM BRIEF PATIENT INFO")
         ...I $G(PSJNEWOE) S NXTPT=0 Q
         ...S NXTPT=1
         ..S NXTPT=1,PSJNEWOE=0
         .S PSJOL="S"
         .I $G(PSGPXN) I $P(PSJSYSW0,U,29)]""!($G(PSJCOM)) S PSGPXPT=PSGP D  K P
          SGPXPT S PSGPXN=0
         ..N DFN,PSGP,PSJPXDP
         ..I $P(PSJSYSW0,U,29)="" S PSJPDXP=1 D
         ...;N IO,ION,IOS D HOME^%ZIS S $P(PSJSYSW0,U,29)=+$G(IOS)
         ...D HOME^%ZIS S $P(PSJSYSW0,U,29)=+$G(IOS)
         ..S (PSGP,DFN)=PSGPXPT D ^PSGPER S:$G(PSJPDXP) $P(PSJSYSW0,U,29)="" K P
          SJPDXP
         .D ENCV^PSGSETU,^PSIVXU
         K PSJLMPRO,^TMP("PSJPRO",$J),^TMP("PSJ",$J),^TMP("PSJON",$J)
DONE     ;
         ; -- RTC 198753 - correct typo - r PSJALGSV w PSJAGYSV
         K PSJAGYSV,PSJEXCPT,PSJOCER,^TMP($J,"PSJPRE"),^TMP("PSODAOC",$J),^TMP("
          PSJDAOC",$J)
         K AC,ACTION,D1,D2,MI,N,ON,P3,PNOW,PSIVAT,PSIVLN,PSIVSTR L -^PS(53.45,PS
          JSYSP)
         K DA,DRG,NE,PSGCF,PSGCANFL,PSGNEDFD,PSGNEF,PSGNEFD,PSGNEPR,PSGNESD,PSJA
          COK,PSJOE,PSJOECNT,PSJOEPF,PSJORD,PSGOEA,PSGOEAV,PSGOL,PSGOS,PSGON,PSG
          OP,PSGORD,PSGS0XT,PSGS0Y,RCT,ST,WD,XREF,Z,PSJIVORF,PSJIVPCL
         K PSGOEORF,PSIVREA,PSJOPC,PSJORL,PSJORPCL,PSJORTOI,RF,WSCHADM,PSJLM,PSJ
          CT
         K DIU,DRGI,FLAG,FQC,ND2,PRI,PSGOE,PSGPRI,PSGSDN,PSGOEDMR,PSGOEPR,PSGPTS
          ,PSGTOL,PSGTOO,PSGUOW,PSJIVOF,PSJOCNT,PSJON,PSJORQF,PSJORTOU,PSJORVP
         K PSIVENO
         G:$G(PSGPXN) ^PSGPER1 D ENIVKV^PSGSETU
         Q
HK       ; Housekeeping (a nice COBOL term)
         I PSGOP,PSGOP'=PSGP D
         .N PSJACPF,PSJACNWP,PSJPWD,PSJSYSL,PSJSYSW,PSJSYSW0,DFN,VAIN,VAERR S DF
          N=PSGOP
         .D INP^VADPT S PSJPWD=+VAIN(4) I PSJPWD S PSJACPF=10 D WP^PSJAC D:$P(PS
          JSYSL,"^",2)]"" ENQL^PSGLW
         Q:PSGP<0
         S (DFN,PSGOP)=PSGP,X=""
         Q
SELECT   ; Select order from list
         ;Variable PSJOCDSC is used in Complex order dosing checks
         N PSGLMT,PSGODDD,PSJLMQT,PSJLMFIN,PSJUDPRF,PSGRDTX,PSJOCDSC,PSJAGYSV K 
          ^TMP("PSJCOM",$J),^TMP("PSJCOM2",$J),PSJSTARI,^TMP("PSODAOC",$J),^TMP(
          "PSJDAOC",$J)
         S PSGONC=1,PSGLMT=^TMP("PSJPRO",$J,0) D ENASR^PSGON
         I "^"[X S VALMQUIT=1 Q
         S PSJLM=1,PSJSEL=0 F  S PSJSEL=$O(PSGODDD(PSJSEL)) Q:'PSJSEL!($G(Y)<0) 
           F PSJSEL1=1:1:$L(PSGODDD(PSJSEL),",")-1 D
         .K PSJOCDSC
         .S PSJORD=$G(^TMP("PSJON",$J,+$P(PSGODDD(PSJSEL),",",PSJSEL1))) D:PSJOR
          D=+PSJORD SELECT^PSJOEA Q:PSJORD=""!($G(Y)<0)  Q:PSJORD=+PSJORD  D
         ..Q:('$$LS^PSSLOCK(PSGP,PSJORD))
         ..Q:PSJORD=+PSJORD
         ..S PSGORD=""
         ..D DISACTIO(PSGP,PSJORD,"") S:PSJORD["V" PSJORD=ON
         ..D UNL^PSSLOCK(PSGP,PSJORD) Q:$G(Y)<0
         S VALMBCK="Q"
         K PSJLM,PSJOCDSC
         Q
DISACTIO(DFN,PSJORD,PSJPNV) --
                ; Display UD order and allow actions.
         ; PSJORD - Order #_location Code (P:53.1,V:55.01,U:55.06)
         ; PSJPNV - Invoked from Pending/NV option; (gets different hidden menu)
         ; PSJDSVFY - Flag if non-vf order was edited
         ; PSJENHOC=1 if DI,DT were display. This will be used by dosing OC to c
          heck if error messages should display or not
         ; PSJAGYSV=1 If UD was edited
         ;N PSGP,PSJIVFLG,PSGSDX,PSGFDX,PSJXX1,ON55,PSJDSVFY,PSJENHOC,PSJAGYSV
         N PSGP,PSJIVFLG,PSGSDX,PSGFDX,PSJXX1,ON55,PSJDSVFY,PSJENHOC,PSIVENO
         D OLDCOM^PSJOE0(DFN,PSJORD)
         S PSGP=DFN D ENIV^PSJAC I PSJORD["V" D EN^PSJLIORD(DFN,PSJORD) Q
         D GETUD^PSJLMGUD(DFN,PSJORD)
         S PSGOEAV=$P(PSJSYSP0,"^",9)&PSJSYSU
         S:$G(PSJTUD) PSGPD=$G(PSJCOI),PSGPDN=$$OINAME^PSJLMUTL(+PSGPD)
         ;; START NCC REMEDIATION >> 327*RJS
         ;I '$G(PSGDRG) S PSGDRG=$O(^PSDRUG("ASP",PSGPD,0)) I PSGDRG,'$O(^(PSGDR
          G)) Q
         ;I PSGSTAT'="ACTIVE",PSGSTAT'="NON-VERIFIED",PSGSTAT'="DISCONTINUED"  D
         ;.S ANQX=0 I $D(^PSDRUG("ACLOZ",PSGDRG)) D CLOZ^PSJCLOZ(PSGP,PSGDRG)
         ;I $G(ANQX) K DIR S DIR(0)="E" D ^DIR K DIR Q
         ;; END NCC REMEDIATION << 327*RJS
         K PSGOENG I '$D(PSGPRF) D  Q:$G(PSGOENG)
         . I PSJORD["U" L +^PS(55,PSGP,5,+PSJORD):1 E  S PSGOENG=1
         . I PSJORD["P" L +^PS(53.1,+PSJORD):1 E  S PSGOENG=1
         . I $G(PSGOENG) W !,"This order is being edited by another terminal.",!
           S PSGOENG=1 K DIR S DIR(0)="E" D ^DIR K DIR Q
         S PSGACT=$$ENACTION^PSGOE1(PSGP,PSJORD)
         I PSJORD["P" S PSJXX1=$G(^PS(53.1,+PSJORD,0)) I PSGP'=$P(PSJXX1,U,15)!(
          DFN'=$P(PSJXX1,U,15)) L -^PS(53.1,+PSJORD) Q
         I PSJORD["P" D  S PSJXX1=$P($G(^PS(53.1,+PSJORD,0)),U,9) I $S($G(PSJIVF
          LG):1,$G(Y)<0:1,"PADE"[PSJXX1:1,1:0) L -^PS(53.1,+PSJORD) Q
         .I $P(PSJXX1,U,9)="N",($P(PSJXX1,U,4)'="U") D  Q
         .. S P("PON")=PSJORD,PSIVFLG=1
         .. N ON S ON=PSJORD D VF^PSIVORC2
         .I $P(PSJXX1,U,9)="P" D  Q
         ..S:$G(PSJTUD) $P(PSJXX1,U,4)="U"
         ..I $P(PSJXX1,U,4)="U" D  Q:$G(PSJIVFLG)
         ... N VAIP S CLINIC=$G(^PS(53.1,+PSJORD,"DSS")),APPT=$P(CLINIC,"^",2),C
          LINIC=$P(CLINIC,"^") I $$PATCH^XPDUTL("SD*5.3*285"),$$SDIMO^SDAMA203(C
          LINIC,DFN)>-1 Q
         ... Q:'PSJPDD  W !!,"Cannot process an Out-patient Unit Dose order for 
          ",$P($G(^DPT(+PSGP,0)),U) D PAUSE^VALM1 S PSJIVFLG=1
         ..NEW PSGRSD,PSGRSDN,PSGRFD,PSGRFDN
         ..D REQDT^PSJLIVMD(PSJORD)
         ..I $P(PSJXX1,U,4)="U",($G(PSGSCH)="") W !!,"Invalid schedule, can't fi
          nish this order" D PAUSE^VALM1 Q
         ..I $P(PSJXX1,U,4)="U" N PSJLM,PSJOCFG S PSJLM=1,PSGORD=PSJORD,PSJOCFG=
          "FN UD" D START^PSGOEF,ENSFE^PSGOEE0(PSGP,PSGORD) S:$G(PSJTUD) PSJOCFG
          ="FN UD" D @$S($G(PSJTUD):"FINISH^PSGOEF",1:"EN^VALM(""PSJ LM PENDING 
          EDIT"")") K PSJOCFG Q
         ..I $P(PSJXX1,U,4)'="U",PSGP=$P(PSJXX1,U,15),DFN=$P(PSJXX1,U,15) S PSJL
          YN=PSJORD,PSJOCFG="FN IV" D EN^PSJLIFN S PSJIVFLG=1 K PSJLYN,PSJMAI,PS
          JOCFG
         I $G(PSIVFLG) K PSIVFLG Q
         S PSGACT=$$ENACTION^PSGOE1(PSGP,PSJORD),PSGOEEF=0 D GETUD^PSJLMGUD(PSGP
          ,PSJORD),ENSFE^PSGOEE0(PSGP,PSJORD),EN^VALM("PSJ LM UD ACTION")
         I PSJORD["P" L -^PS(53.1,+PSJORD)
         I PSJORD["U" L -^PS(55,PSGP,5,+PSJORD)
         ;Send SN to CPRS if auto-verify OFF and Order Set Entry and no 21st pie
          ce
         S PSGOEAV=$P(PSJSYSP0,"^",9)&PSJSYSU
         I $D(PSGOES),'PSGOEAV,$D(PSGORD),PSGORD["P",$P($G(^PS(53.1,+PSGORD,0)),
          "^",21)']"" D ORSET^PSGOETO1
         I $G(PSGOEAV),($G(PSGOES)=1) D SETOC ;Store allergy for order set /w au
          to vf 
         I '$G(PSGOEAV),($G(PSJORD)["P"),$S($G(PSJAGYSV):1,($G(PSJOCFG)="NEW UD"
          ):1,1:0) D SETOC
         D UNL^PSSLOCK(PSGP,PSJORD)
         Q
SETOC    ;
         ;RTC 178789 
         S ^TMP("PSODAOC",$J,"IP IEN")=PSJORD
         D SETOC^PSJNEWOC(PSJORD)
         K ^TMP("PSODAOC",$J),^TMP("PSJDAOC",$J),PSJAGYSV,PSJOCFG
         Q
EDIT(PSGP,PSGORD,PROMPT) --
          ;
         I "DE"[$$GTSTATUS(PSGP,PSGORD) W !,"This order may not be edited." D PA
          USE^VALM1 Q
         I PSGACT'["E" W !,"This order may not be edited." D PAUSE^VALM1 Q
         N PSJEDITO S PSJEDITO=1
         S PSJAGYSV=1 ;Flag to store allergy data in 100.05.
         S PSGNEDFD="" D HOLDHDR,@$S('PROMPT:"ENEFA2^PSGON",1:"ENEFA^PSGON") I '
          Y D ABORT^PSGOEE Q
         I PSGORD["P" D ENF^PSGOEE Q
         D ACT^PSGOEE
         Q
RENEW(PSGP,PSGORD) --
          ;
         ;PSJOCFG - If defined, it's for new order, renew or copy. ^PSJOCDSD usi
          ng this flag to not display drug error.
         NEW PSJOCFG
         S PSJOCFG="RENEW UD"
         D HOLDHDR
         I 'PSJSYSU,$P($G(^PS(55,PSGP,5,+PSGORD,4)),U,15),$P($G(^(4)),U,16) W !!
          ,"This order is already marked for renewal!" D PAUSE^VALM1 S VALMBCK="
          R" Q
         I 'PSGRRF D ^PSGOER K PSJOCFG Q
         D ^PSGOERI
         K PSJOCFG
         Q
GTSTATUS(DFN,ON) --
            ;
         I ON["P" Q $P($G(^PS(53.1,+ON,0)),U,9)
         I ON["U" Q $P($G(^PS(55,DFN,5,+ON,0)),U,9)
         Q $P($G(^PS(55,DFN,"IV",+ON,0)),U,17)
DC(DFN,PSJORD) --
          ; DC IV, UD, or pending orders.
         D HOLDHDR
         S X=$$GTSTATUS(DFN,PSJORD) I X="D"!(X="DE")!(X="R") W !,$S(X="R":"This 
          order has a pending renewal and cannot be DISCONTINUED.",1:"This order
           has already been DISCONTINUED.") D PAUSE^VALM1 Q
         D ENO^PSGOEC(DFN,PSJORD) ;,GETUD^PSJLMGUD(DFN,PSJORD),INIT^PSJLMUDE(DFN
          ,PSJORD) S VALMBCK="Q"
         S VALMBCK="Q"
         Q
HOLD(DFN,PSJORD) --
          ; Change order's status from ACTIVE<->HOLD
         D HOLDHDR
         I PSJORD["V" D H^PSIVOPT(DFN,PSJORD,P(17),P(3))
         I PSJORD'["V" D H^PSGOE1(DFN,PSJORD)
         D GETUD^PSJLMGUD(DFN,PSJORD),INIT^PSJLMUDE(DFN,PSJORD) S PSGACT=$$ENACT
          ION^PSGOE1(DFN,PSJORD),VALMBCK="R"
         Q
COPY(PSGP,PSGORD) --
           ; Copy an order (does not discontinue original order)
         NEW PSJOCFG
         I $D(PSGCOPY) W !!,"You cannot copy the order at this time" D PAUSE^VAL
          M1 Q
         I PSGORD["P" W !!,"You cannot copy this "_$S($G(PSGSTAT)]"":PSGSTAT,1:"
          PENDING IV")_" order." D PAUSE^VALM1 Q
         I PSGORD["V" D  Q
         .I $G(PSIVCOPY) W !!,"You cannot copy the order at this time" D PAUSE^V
          ALM1 Q
         .S PSJOCFG="COPY IV"
         .D COPY^PSIVOD(PSGP,PSGORD) K PSJOCFG Q
         Q:'$$HIDDEN^PSJLMUTL("COPY")
         D ^PSJHVARS
         I $P($G(^PS(55,PSGP,5,+PSGORD,.2)),U,4)="D",'$P($G(^(4)),"^",3) W !!,"N
          urse verified orders with a priority of DONE may not be Copied." D PAU
          SE^VALM1 Q
         S PSJOCFG="COPY UD"
         S PSGOEAV=$P(PSJSYSP0,U,9)&PSJSYSU
         S PSGCOPY=1
         D FULL^VALM1,^PSGOD
         ;/RBN Begin modifications PSJ*5.0*327
         Q:$G(ANQX)
         ;/RBN End modifications PSJ*5.0*327
         S VALMBCK="R"
         K PSGCOPY,PSJOCFG
         S PSGACT=$$ENACTION^PSGOE1(PSGP,PSGORD) ; resets PSGACT after copy
         I $G(PSGPXN) N PSGTMPXN S PSGTMPXN=PSGPXN
         D RESTORE^PSJHVARS I $G(PSGTMPXN) S PSGPXN=PSGTMPXN
         Q
UPDATE   ; Refresh array, actions, & display.
         D GETUD^PSJLMGUD(DFN,ON),INIT^PSJLMUDE(DFN,ON) S VALMBCK="R"
         Q
FINISH   ;
         D FINISH^PSGOEF,PAUSE^VALM1
         Q
LOG(DFN,PSGORD) --
                 ;
         D FULL^VALM1,ENLM^PSGOEL(DFN,PSGORD),PAUSE^VALM1 S VALMBCK="R"
         Q
NEWSEL   ;
         N PSGLMT,PSGODDD,PSJLMQT,PSJLMFIN,PSJUDPRF,PSGRDTX,PSJOCDSC,PSJAGYSV K 
          ^TMP("PSJCOM",$J),^TMP("PSJCOM2",$J),^TMP("PSODAOC",$J),^TMP("PSJDAOC"
          ,$J)
         ;; START NCC REMEDIATION >> 327*RJS +-   
         S IOTM=VALM("TM"),IOBM=IOSL W IOSC W @IOSTBM W IORC
         ;; END NCC REMEDIATION << 327*RJS
         S X=$P(XQORNOD(0),"=",2)
         S PSGONC=1,PSGLMT=^TMP("PSJPRO",$J,0)
         D ENCHK^PSGON I '$O(PSGODDD(0)) S VALMQUIT=1 Q
         S PSJLM=1,PSJSEL=0 F  S PSJSEL=$O(PSGODDD(PSJSEL)) Q:'PSJSEL  F PSJSEL1
          =1:1:$L(PSGODDD(PSJSEL),",")-1 D
         .K PSJOCDSC,PSGDRG
         .S PSJORD=$G(^TMP("PSJON",$J,+$P(PSGODDD(PSJSEL),",",PSJSEL1))) D:PSJOR
          D=+PSJORD SELECT^PSJOEA
         .Q:PSJORD=+PSJORD 
         .Q:PSJORD=""!($G(Y)<0)  Q:('$$LS^PSSLOCK(PSGP,PSJORD))  D
         ..S PSGORD=""
         ..S ON=PSJORD
         ..D DISACTIO(PSGP,PSJORD,$G(PSJPNV)) S:PSJORD["V" PSJORD=ON
         ..D UNL^PSSLOCK(PSGP,PSJORD)
         ..I $G(PSJNOL) K PSJNOL I $D(ON),ON'=PSJORD D UNL^PSSLOCK(PSGP,ON)
         ..Q:$G(Y)<0
         I '$G(PSGOEAV),($G(PSJORD)["P"),$G(PSJAGYSV) D
         .;RTC 178789 
         .S ^TMP("PSODAOC",$J,"IP IEN")=PSJORD
         .D SETOC^PSJNEWOC(PSJORD)
         .K ^TMP("PSODAOC",$J),^TMP("PSJDAOC",$J),PSJAGYSV
         S VALMBCK="Q"
         K PSJLM,PSJOCDSC
         Q
HOLDHDR  ; Freeze header text while processing order actions
         I $D(VALM("TM")) S IOTM=VALM("TM"),IOBM=IOSL W IOSC W @IOSTBM W IORC
         Q
LOCKERR  ;
         W !!,$C(7),"You are entering or editing an Inpatient Medication order i
          n another session.",!,"Only one order entry/edit session is allowed fo
          r a user at a time.",!! N DIR S DIR(0)="E" D ^DIR
         Q
FLAG(DFN,PSJORD) --
          ;Flag order through CPRS entry point.
         N ORIFN,NODE0
         S NODE0=$S(PSJORD["V":$G(^PS(55,DFN,"IV",+PSJORD,0)),PSJORD["U":$G(^PS(
          55,DFN,5,+PSJORD,0)),1:^PS(53.1,+PSJORD,0))
         S ORIFN=$P(NODE0,"^",21)
         D EN1^ORCFLAG(ORIFN)
         D PAUSE^VALM1
         Q
COMPLEX(DFN,ON) --
          ;
         N NDP2,COM
         S NDP2=$S(ON["P":$G(^PS(53.1,+ON,.2)),ON["U":$G(^PS(55,DFN,5,+ON,.2)),O
          N["V":$G(^PS(55,DFN,"IV",+ON,.2)),1:"")
         S COM=$P(NDP2,"^",8) I COM Q 1
         Q 0
CLOZSND  ; SEND CLOZAPINE OVERRIDE MESSAGE AND ORDER TO HINES DB
         ;; START NCC REMEDIATION >> 327*RJS
         S PSJYSCL=0
         I $D(YSCLR),$P(YSCLR,"^",4)>1500 N PSJYSCL S PSJYSCL=1 ;; NCC REMEDITAT
          ION RTW
         I PSJYSCL'=1,$D(^PSDRUG("ACLOZ",+$G(PSGDN))) D PSJFILE^PSJCLOZ(DFN),INP
          SND^YSCLTST5 ; Added $G tp PSGDN
         S PSJYSCL=1
         ;; END NCC REMEDIATION << 327*RJS
         Q

*****   INDEX OF PSJOE   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   AC           DONE+3!
   ACTION       DONE+3!
>> ANQX         COPY+16
>> APPT         DISACTIO+32*
>> CLINIC       DISACTIO+32*
   COM          COMPLEX+1~,COMPLEX+3*
   D1           DONE+3!
   D2           DONE+3!
   DA           DONE+4!
   DFN          EN+4*,EN+21~,EN+25*,HK+2~*,HK+5*,DISACTIO~,DISACTIO+8
                DISACTIO+9,DISACTIO+10,DISACTIO+24,DISACTIO+32,DISACTIO+38
                GTSTATUS~,GTSTATUS+2,GTSTATUS+3,DC~,DC+2,DC+3,HOLD~,HOLD+2
                HOLD+3,HOLD+4,UPDATE+1,LOG~,LOG+1,FLAG~,FLAG+2,COMPLEX~
                COMPLEX+2
                CLOZSND+4
   DIR          DISACTIO+22!,LOCKERR+1~
   DIR(0        DISACTIO+22*,LOCKERR+1*
   DIU          DONE+6!
   DRG          DONE+4!
   DRGI         DONE+6!
   FLAG         DONE+6!
   FQC          DONE+6!
>> IOBM         NEWSEL+3*,HOLDHDR+1*
>> IORC         NEWSEL+3,HOLDHDR+1
>> IOS          EN+24
>> IOSC         NEWSEL+3,HOLDHDR+1
   IOSL         NEWSEL+3,HOLDHDR+1
>> IOSTBM       NEWSEL+3,HOLDHDR+1
>> IOTM         NEWSEL+3*,HOLDHDR+1*
   MI           DONE+3!
   N            DONE+3!
   ND2          DONE+6!
   NDP2         COMPLEX+1~,COMPLEX+2*,COMPLEX+3
   NE           DONE+4!
   NODE0        FLAG+1~,FLAG+2*,FLAG+3
   NXTPT        EN+8~*,EN+16*,EN+17*,EN+18*
   ON           DONE+3!,SELECT+11,DISACTIO+28~*,GTSTATUS~,GTSTATUS+1,GTSTATUS+2
                GTSTATUS+3,UPDATE+1,NEWSEL+14*,NEWSEL+15,NEWSEL+17,COMPLEX~
                COMPLEX+2
   ON55         DISACTIO+7~
   ORIFN        FLAG+1~,FLAG+3*,FLAG+4
>> P("PON"      DISACTIO+27*
>> P(17         HOLD+2
>> P(3          HOLD+2
   P3           DONE+3!
   PNOW         DONE+3!
   PRI          DONE+6!
   PROMPT       EDIT~,EDIT+5
>> PSGACT       DISACTIO+23*,DISACTIO+40*,EDIT+2,HOLD+4*,COPY+20*
   PSGCANFL     DONE+4!
   PSGCF        DONE+4!
   PSGCOPY      COPY+2,COPY+13*,COPY+19!
>> PSGDN        CLOZSND+4
   PSGDRG       NEWSEL+9!
   PSGFDX       DISACTIO+7~
   PSGLMT       SELECT+2~,SELECT+3*,NEWSEL+1~,NEWSEL+6*
   PSGNEDFD     DONE+4!,EDIT+5*
   PSGNEF       EN+3*,DONE+4!
   PSGNEFD      DONE+4!
   PSGNEPR      DONE+4!
   PSGNESD      DONE+4!
   PSGODDD      SELECT+2~,NEWSEL+1~
   PSGODDD(     SELECT+5,SELECT+7,NEWSEL+8,NEWSEL+10
   PSGODDD(0    NEWSEL+7
   PSGOE        DONE+6!
   PSGOEA       DONE+4!
   PSGOEAV      EN+3*,DONE+4!,DISACTIO+11*,DISACTIO+44*,DISACTIO+45,DISACTIO+46
                DISACTIO+47,COPY+12*,NEWSEL+19
   PSGOEDMR     DONE+6!
>> PSGOEEF      DISACTIO+40*
   PSGOENG      DISACTIO+19!,DISACTIO+20*,DISACTIO+21*,DISACTIO+22*
   PSGOEORF     DONE+5!
   PSGOEPR      DONE+6!
>> PSGOES       DISACTIO+45,DISACTIO+46
   PSGOL        DONE+4!
   PSGON        DONE+4!
>> PSGONC       SELECT+3*,NEWSEL+6*
   PSGOP        EN+3*,DONE+4!,HK+1,HK+2,HK+5*
   PSGORD       DONE+4!,SELECT+10*,DISACTIO+37*,DISACTIO+45,EDIT~,EDIT+1,EDIT+6
                RENEW~,RENEW+5,COPY~,COPY+3,COPY+4,COPY+7,COPY+10,COPY+20,LOG~
                LOG+1,NEWSEL+13*
   PSGOS        DONE+4!
   PSGP         EN+4,EN+6,EN+20,EN+21~,EN+25*,HK+1,HK+4,HK+5,SELECT+8,SELECT+11
                SELECT+12,DISACTIO+7~,DISACTIO+9*,DISACTIO+20,DISACTIO+23
                DISACTIO+24,DISACTIO+33,DISACTIO+37,DISACTIO+38,DISACTIO+40
                DISACTIO+42,DISACTIO+48,EDIT~,EDIT+1,RENEW~,RENEW+5
                COPY~,COPY+7,COPY+10,COPY+20,NEWSEL+12,NEWSEL+15,NEWSEL+16
                NEWSEL+17
>> PSGPD        DISACTIO+12*
>> PSGPDN       DISACTIO+12*
>> PSGPRF       DISACTIO+19
   PSGPRI       DONE+6!
>> PSGPTMP      EN+4*
   PSGPTS       DONE+6!
>> PSGPXN       EN+3*,EN+20*,DONE+8,COPY+21,COPY+22*
   PSGPXPT      EN+20*!,EN+25
   PSGRDTX      EN+9!,SELECT+2~,NEWSEL+1~
   PSGRFD       DISACTIO+34~
   PSGRFDN      DISACTIO+34~
>> PSGRRF       RENEW+6
   PSGRSD       DISACTIO+34~
   PSGRSDN      DISACTIO+34~
   PSGS0XT      DONE+4!
   PSGS0Y       DONE+4!
>> PSGSCH       DISACTIO+36
   PSGSDN       DONE+6!
   PSGSDX       DISACTIO+7~
>> PSGSTAT      COPY+3
   PSGTMPXN     COPY+21~*,COPY+22
   PSGTOL       DONE+6!
   PSGTOO       DONE+6!
   PSGUOW       DONE+6!
   PSGVBY       EN+3!
   PSIVAT       DONE+3!
>> PSIVCOPY     COPY+5
   PSIVENO      DONE+7!,DISACTIO+7~
   PSIVFLG      DISACTIO+27*,DISACTIO+39!
   PSIVLN       DONE+3!
   PSIVREA      DONE+5!
   PSIVSTR      DONE+3!
   PSJACNWP     HK+2~
   PSJACOK      EN+3*,DONE+4!
   PSJACPF      HK+2~,HK+3*
   PSJAGYSV     DONE+2!,SELECT+2~,DISACTIO+47,SETOC+4!,EDIT+4*,NEWSEL+1~
                NEWSEL+19,NEWSEL+23!
>> PSJCOI       DISACTIO+12
>> PSJCOM       EN+20
   PSJCT        DONE+5!
   PSJDSVFY     DISACTIO+7~
   PSJEDITO     EDIT+3~*
   PSJENHOC     DISACTIO+7~
   PSJEXCPT     DONE+2!
   PSJIVFLG     DISACTIO+7~,DISACTIO+25,DISACTIO+31,DISACTIO+33*,DISACTIO+38*
   PSJIVOF      DONE+6!
   PSJIVORF     DONE+4!
   PSJIVPCL     DONE+4!
   PSJLK        EN+1~,EN+4,EN+6*
   PSJLM        DONE+5!,SELECT+5*,SELECT+14!,DISACTIO+37~*,NEWSEL+8*,NEWSEL+25!
   PSJLMCON     EN+1~,EN+4*,EN+10,EN+12*,EN+14,EN+15*
   PSJLMFIN     SELECT+2~,NEWSEL+1~
   PSJLMPRO     EN+7!,EN+12*,EN+14,EN+15*,EN+27!
   PSJLMQT      SELECT+2~,NEWSEL+1~
   PSJLYN       DISACTIO+38*!
   PSJMAI       DISACTIO+38!
   PSJNEWOE     EN+1~,EN+10,EN+12*,EN+13*,EN+16,EN+18*
   PSJNOL       NEWSEL+17!
   PSJOCDSC     SELECT+2~,SELECT+6!,SELECT+14!,NEWSEL+1~,NEWSEL+9!,NEWSEL+25!
   PSJOCER      DONE+2!
   PSJOCFG      DISACTIO+37~*!,DISACTIO+38*!,DISACTIO+47,SETOC+4!,RENEW+2~
                RENEW+3*,RENEW+6!,RENEW+8!,COPY+1~,COPY+6*,COPY+7!,COPY+11*
                COPY+19!
   PSJOCNT      DONE+6!
   PSJOE        DONE+4!
   PSJOECNT     DONE+4!
   PSJOEPF      DONE+4!
>> PSJOL        EN+3*,EN+11*,EN+19*
   PSJON        DONE+6!
   PSJOPC       DONE+5!
   PSJORD       DONE+4!,SELECT+7*,SELECT+8,SELECT+9,SELECT+11*,SELECT+12
                DISACTIO~,DISACTIO+8,DISACTIO+9,DISACTIO+10,DISACTIO+20
                DISACTIO+21,DISACTIO+23,DISACTIO+24,DISACTIO+25,DISACTIO+27
                DISACTIO+28,DISACTIO+32,DISACTIO+35,DISACTIO+37,DISACTIO+38
                DISACTIO+40,DISACTIO+41,DISACTIO+42,DISACTIO+47,DISACTIO+48
                SETOC+2,SETOC+3,DC~,DC+2,DC+3,HOLD~,HOLD+2,HOLD+3,HOLD+4
                NEWSEL+10*,NEWSEL+11,NEWSEL+12,NEWSEL+14,NEWSEL+15*,NEWSEL+16
                NEWSEL+17,NEWSEL+19,NEWSEL+21,NEWSEL+22,FLAG~,FLAG+2
   PSJORL       DONE+5!
   PSJORPCL     DONE+5!
   PSJORQF      DONE+6!
   PSJORTOI     DONE+5!
   PSJORTOU     DONE+6!
   PSJORVP      DONE+6!
>> PSJPDD       DISACTIO+33
   PSJPDXP      EN+22*,EN+25!
   PSJPNV       DISACTIO~,NEWSEL+15
   PSJPR        EN+3!
   PSJPROT      EN+1~,EN+4*
   PSJPWD       HK+2~,HK+3*
   PSJPXDP      EN+21~
>> PSJSEL       SELECT+5*,SELECT+7,NEWSEL+8*,NEWSEL+10
>> PSJSEL1      SELECT+5*,SELECT+7,NEWSEL+8*,NEWSEL+10
   PSJSTARI     SELECT+2!
   PSJSYSL      HK+2~,HK+3
>> PSJSYSP      EN+3,DONE+3
>> PSJSYSP0     DISACTIO+11,DISACTIO+44,COPY+12
>> PSJSYSU      DISACTIO+11,DISACTIO+44,RENEW+5,COPY+12
   PSJSYSW      HK+2~
   PSJSYSW0     EN+20,EN+22,EN+24*,EN+25*,HK+2~
>> PSJTUD       DISACTIO+12,DISACTIO+30,DISACTIO+37
   PSJUDPRF     SELECT+2~,NEWSEL+1~
   PSJXX1       DISACTIO+7~,DISACTIO+24*,DISACTIO+25*,DISACTIO+26,DISACTIO+29
                DISACTIO+30*,DISACTIO+31,DISACTIO+36,DISACTIO+37,DISACTIO+38
   PSJYSCL      CLOZSND+2*,CLOZSND+3~*,CLOZSND+4,CLOZSND+5*
   RCT          DONE+4!
   RF           DONE+5!
   ST           DONE+4!
   U            EN+6,EN+20,EN+22,EN+24,EN+25,DISACTIO+24,DISACTIO+25
                DISACTIO+26,DISACTIO+29,DISACTIO+30,DISACTIO+31,DISACTIO+33
                DISACTIO+36,DISACTIO+37,DISACTIO+38,RENEW+5,GTSTATUS+1
                GTSTATUS+2,GTSTATUS+3,COPY+10,COPY+12
   VAERR        HK+2~
   VAIN         HK+2~
   VAIN(4       HK+3
   VAIP         DISACTIO+32~
>> VALM("TM"    NEWSEL+3,HOLDHDR+1
>> VALMBCK      EN+13,SELECT+13*,RENEW+5*,DC+4*,HOLD+4*,COPY+18*,UPDATE+1*
                LOG+1*,NEWSEL+24*
   VALMEVL      EN+1~
>> VALMQUIT     SELECT+4*,NEWSEL+7*
   WD           DONE+4!
   WSCHADM      DONE+5!
>> X            HK+5*,SELECT+4,DC+2*,NEWSEL+5*
>> XQORNOD(0    NEWSEL+5
   XQORS        EN+1~
   XQUIT        EN+2!
   XREF         DONE+4!
>> Y            SELECT+5,SELECT+7,SELECT+12,DISACTIO+25,EDIT+5,NEWSEL+12
                NEWSEL+18
>> YSCLR        CLOZSND+3
   Z            DONE+4!

Global Variables  ( * Changed  ! Killed)
   ^DPT(               DISACTIO+33
   ^PS(53.1            DISACTIO+21,DISACTIO+24,DISACTIO+25,DISACTIO+32
                       DISACTIO+41,DISACTIO+45,GTSTATUS+1,FLAG+2,COMPLEX+2
   ^PS(53.45           EN+3,DONE+3
   ^PS(55              DISACTIO+20,DISACTIO+42,RENEW+5,GTSTATUS+2,GTSTATUS+3
                       COPY+10,FLAG+2,COMPLEX+2
   ^PSDRUG("ACLOZ"     CLOZSND+4
   ^TMP("PSJ"          EN+5!,EN+14,EN+27!
   ^TMP("PSJCOM"       SELECT+2!,NEWSEL+1!
   ^TMP("PSJCOM2"      SELECT+2!,NEWSEL+1!
   ^TMP("PSJDAOC"      DONE+2!,SELECT+2!,SETOC+4!,NEWSEL+1!,NEWSEL+23!
   ^TMP("PSJON"        EN+27!,SELECT+7,NEWSEL+10
   ^TMP("PSJPRO"       EN+27!,SELECT+3,NEWSEL+6
   ^TMP("PSODAOC"      DONE+2!,SELECT+2!,SETOC+2*,SETOC+4!,NEWSEL+1!,NEWSEL+21*
                       NEWSEL+23!
   ^TMP($J             DONE+2!

Naked Globals
   ^(4          RENEW+5,COPY+10

Cache Objects
   NONE

Marked Items
   NONE

Label References
   $$GTSTATUS   EDIT+1,DC+2
   @(           DISACTIO+37,EDIT+5
   DISACTIO     SELECT+11,NEWSEL+15
   DONE         EN+2
   HK           EN+4
   HOLDHDR      EDIT+5,RENEW+4,DC+1,HOLD+1
   SETOC        DISACTIO+46,DISACTIO+47

External References
   HOME^%ZIS           EN+24
   ^DIR                DISACTIO+22,LOCKERR+1
   EN1^ORCFLAG         FLAG+4
   ENQL^PSGLW          HK+3
   ^PSGOD              COPY+14
   $$ENACTION^PSGOE1   DISACTIO+23,DISACTIO+40,HOLD+4,COPY+20
   H^PSGOE1            HOLD+3
   ENO^PSGOEC          DC+3
   ABORT^PSGOEE        EDIT+5
   ACT^PSGOEE          EDIT+7
   ENF^PSGOEE          EDIT+6
   ENSFE^PSGOEE0       DISACTIO+37,DISACTIO+40
   FINISH^PSGOEF       FINISH+1
   START^PSGOEF        DISACTIO+37
   ENLM^PSGOEL         LOG+1
   ^PSGOER             RENEW+6
   ^PSGOERI            RENEW+7
   ORSET^PSGOETO1      DISACTIO+45
   ENASR^PSGON         SELECT+3
   ENCHK^PSGON         NEWSEL+7
   ^PSGPER             EN+25
   ^PSGPER1            DONE+8
   ENCV^PSGSETU        EN+1,EN+26
   ENIVKV^PSGSETU      DONE+8
   COPY^PSIVOD         COPY+7
   H^PSIVOPT           HOLD+2
   VF^PSIVORC2         DISACTIO+28
   ^PSIVXU             EN+1,EN+26
   ^PSJAC              EN+4
   ENIV^PSJAC          DISACTIO+9
   WP^PSJAC            HK+3
   PSJFILE^PSJCLOZ     CLOZSND+4
   ^PSJHVARS           COPY+9
   RESTORE^PSJHVARS    COPY+22
   EN^PSJLIFN          DISACTIO+38
   EN^PSJLIORD         DISACTIO+9
   REQDT^PSJLIVMD      DISACTIO+35
   GETUD^PSJLMGUD      DISACTIO+10,DISACTIO+40,HOLD+4,UPDATE+1
   INIT^PSJLMUDE       HOLD+4,UPDATE+1
   $$HIDDEN^PSJLMUTL   COPY+8
   $$OINAME^PSJLMUTL   DISACTIO+12
   SETOC^PSJNEWOC      SETOC+3,NEWSEL+22
   DONE^PSJOE          EN+3
   LOCKERR^PSJOE       EN+3
   OLDCOM^PSJOE0       DISACTIO+8
   SELECT^PSJOEA       SELECT+7,NEWSEL+10
   ^PSJP               EN+4
   $$L^PSSLOCK         EN+6
   $$LS^PSSLOCK        SELECT+8,NEWSEL+12
   UL^PSSLOCK          EN+4
   UNL^PSSLOCK         SELECT+12,DISACTIO+48,NEWSEL+16,NEWSEL+17
   $$SDIMO^SDAMA203    DISACTIO+32
   INP^VADPT           HK+3
   EN^VALM             EN+7,EN+12,EN+15,DISACTIO+40
   FULL^VALM1          COPY+14,LOG+1
   PAUSE^VALM1         DISACTIO+33,DISACTIO+36,EDIT+1,EDIT+2,RENEW+5,DC+2
                       COPY+2,COPY+3,COPY+5,COPY+10,FINISH+1,LOG+1,FLAG+5
   $$PATCH^XPDUTL      DISACTIO+32
   INPSND^YSCLTST5     CLOZSND+4

*****   END   *****


PSJOE1   * *  103 Lines,  5259 Bytes, Checksum: B34250433
                                                  Jul 01, 2016@13:24:55 page 22
              903 bytes in comments
PSJOE1   ;BIR/CML3-UD OE FOR COMBINED OE ;29 JAN 99 / 9:44 AM
         ;;5.0;INPATIENT MEDICATIONS;**2,7,25,30,47,56,64,179,181,252,281,327**;
          16 DEC 97;Build 10
         ;
         ; Reference to ^DICN is supported by DBIA# 10009
         ; Reference to ^VALM is supported by DBIA# 10118
         ; Reference to ^TMP("PSODAOC",$J supported by DBIA 6071
         ;
         S PC=0 G AD
         ;
EN       ;
         S PC=0
         ;
AD       ; Ask Drug
         ;PSJOCFG - If defined, it's for new order, renew or copy. ^PSJOCDSD usi
          ng this flag to not display drug error.
         K PSJOCFG
         N PSJNORD,PSGORQF,PSGSDX,PSGFDX,PSGNEFDO,PSGEDTOI,PSJOCFG S PSJOCFG="NE
          W UD" S PSJNORD=1 I $D(VALM("TM")) S IOTM=VALM("TM"),IOBM=IOSL W IOSC,
          @IOSTBM,IORC
         K PSGORQF
         D ^PSGOE7
         I $G(PSGORQF) S PSJORQF=1 G DONE
         S PC=1,PSJORQF=0 I X?1"S."1.E D ^PSGOES G AD
         D ^PSGOE4:'$P(PSJSYSP0,"^",12),^PSGOE3:$P(PSJSYSP0,"^",12)
         G:$G(PSGOROE1)=1 AD
         K PSGEFN,PSGOEEF,PSGOEE,PSGOEOS S PSGEFN="1:13" F X=1:1:13 S PSGEFN(X)=
          ""
         S PSGPDN=$$OINAME^PSJLMUTL(PSGPDRG),PSGPD=PSGPDRG,PSGOINST="",PSGSDN=$$
          ENDD^PSGMI(PSGNESD)_U_$$ENDTC^PSGMI(PSGNESD),PSGFDN=$$ENDD^PSGMI(PSGNE
          FD)_U_$$ENDTC^PSGMI(PSGNEFD)
         S PSGAT=PSGS0Y,PSGLIN=$$ENDD^PSGMI(PSGDT)_U_$$ENDTC^PSGMI(PSGDT),PSGLI=
          PSGDT,PSGEBN=$$ENNPN^PSGMI(DUZ),PSGSTAT=$S(PSGOEAV:"ACTIVE",1:"NON-VER
          IFIED")
         D CHK^PSGOEV("^^"_PSGMR_"^^^^"_PSGST,PSGPDRG_U_PSGDO,PSGSCH_U_PSGNESD_"
          ^^"_PSGNEFD)
         S PSGSD=PSGNESD,PSGFD=PSGNEFD
         K PSJACEPT S VALMBCK="Q" D:$D(Y) EN^VALM("PSJU LM ACCEPT")
         I $G(PSJACEPT)=1 D
         . D OC
         . ;D:'$G(PSGORQF) IN^PSJOCDS($G(PSGORD),"UD",+$G(PSGDRG))
         ;If intervention is not log then quit
         I $G(PSGORQF)=1 S PSJACEPT=0
         S PSJNOO=-1 I $G(PSJACEPT)=1 S PSJNOO=$$ENNOO^PSJUTL5("N")
         I $G(PSJNOO)<0 K PSJACEPT W !,"No order created." G AD
         K PSGOEE D ^PSGOETO S PSJORD=PSGORD
         S ^TMP("PSODAOC",$J,"IP IEN")=PSGORD
         ;RTC 178746 - Don't store allergy here.
         ;D SETOC^PSJNEWOC(PSGORD)
         I PSGOEAV D  G AD
         .;; START NCC REMEDIATION >> 327*RJS
         .I $G(PSGPDN)["CLOZ" D
         ..S ^PS(55,PSGP,5,+$G(PSGORD),"SAND")=PSGTDD
         .;; END NCC REMEDIATION >> 327*RJS
         . D SETOC^PSJNEWOC(PSGORD) ;RTC 17874
         .D CLOZSND^PSJOE K PSGDN,PSJYSCL
         .I '$D(PSGOEE),+PSJSYSU=3 D EN^PSGPEN(PSGORD)
         S PSGOEEF=0 D GETUD^PSJLMGUD(PSGP,PSGORD),ENSFE^PSGOEE0(PSGP,PSGORD),^P
          SGOE1,EN^VALM("PSJ LM UD ACTION")
         ;RTC 178746 - store allergy if not verify the newly created order.
         I ($G(PSGORD)["P"),($P($G(^PS(53.1,+PSGORD,0)),U,9)="N"),($G(PSJOCFG)="
          NEW UD") D SETOC^PSJNEWOC(PSGORD)
         G AD
         Q
OC       ;
         NEW PSJDD,PSJALLGY,PSJALGY1
         K PSGORQF
         ;; START NCC REMEDIATION >> 327*RJS
         I $D(^PSDRUG("ACLOZ",PSGDRG)) D
         .S DIR(0)="N^12.5:3000:1",DIR("A")="CLOZAPINE dosage (mg/day) ? " D ^DI
          R K DIR S:$D(DIRUT) CHK=1 G DONE:$G(CHK)
         .S PSGTDD=X,PSGDN=PSGDRG
         ;; END NCC REMEDIATION >> 327*RJS
         D FULL^VALM1
         S PSJDD=+$$DD53P45^PSJMISC() I 'PSJDD S PSGORQF=1 Q
         I +$G(PSGEDTOI) D
         . S PSJALGY1=1
         . D ENDDC^PSGSICHK($G(PSGP),PSJDD)
         D:'$G(PSGORQF) IN^PSJOCDS($G(PSGORD),"UD",PSJDD)
         Q
EDIT(PROMPT) --
          ;
         ; Edit fields in a UD order.
         ; PROMPT=0 - Select fields to edit by number.
         ; PROMPT=1 - Prompt to select fields for editing.
         ;
         ;* D @$S('PROMPT:"ENEFA2^PSGON",1:"ENEFA^PSGON") Q:'Y  S PSGOEEG=3 D ED
          IT^PSGOEE ;$S(PSGOEEWF[53.1:3,1:5) D:Y EDIT^PSGOEE
         D @$S('PROMPT:"ENEFA2^PSGON",1:"ENEFA^PSGON") Q:'Y  S:$G(PSJNEWOE) PSGO
          EEWF="^PS(53.1," S PSGOEEG=$S('$D(PSGOEEWF):3,PSGOEEWF[53.1:3,1:5) D E
          DIT^PSGOEE
         I $G(PSJNEWOE) S PSGOEENO=0,DR="",VALMBCK="R"
         I '$G(PSJNEWOE) D ENNOU^PSGOEE0 I 'PSGOEENO,DR="" S VALMBCK="R" Q
         I 'PSGOEENO,$D(PSGOES) D ENNOU^PSGOEE0  ; only update on order sets
         ;*179 No longer call CKDT^PSGOEE from here.
         ;I 'PSGOEENO,$G(PSGPDNX)=1 D CKDT^PSGOEE
         I $G(PSGOEER)["101^PSGOE8" S PSGEDTOI=1
         K VALMSG I PSGOEENO D
         .S VALMSG="This change will cause a new order to be created." D GTSTATU
          S^PSGOEE,CHKDD^PSGOEE
         .S PSGEBN=$$ENNPN^PSGMI(DUZ),PSGLIN=$$ENDD^PSGMI(PSGDT)_U_$$ENDTC^PSGMI
          (PSGDT),PSGLI=PSGDT
         D CHK^PSGOEV("^^"_PSGMR_"^^^^"_PSGST,PSGPDRG_U_PSGDO,PSGSCH_U_PSGSD_"^^
          "_PSGFD)
         D INIT^PSJLMUDE(PSGP,$G(PSGORD))
         Q
DONE     ;
         K %,DA,DIC,DIE,DR,DRG,DRGN,DRGO,ND,OC,ORIFN,ORIT,ORPK,ORSTOP,ORSTRT,ORS
          TS,ORTX,PC,PSGDO,PSGMR,PSGMRN,PSGNEDFD,PSGNEFD,PSGNESD,PSGOES,PSGOROE1
          ,PSGORD,PSGS0XT,PSGS0Y,PSGSCH,PSGSI,PSGX,Y,Z Q
         K PSGEDTOI,PSJOCFG
         ;
GDO      ;
         W !!,"Drug is not found in Formulary List." F  S %=1 W !,"Would you lik
          e to try to search the list again" D YN^DICN Q:%  D TAM
         Q:%<2
FTD      ;
         R !!,"Enter FREE TEXT DRUG: ",PSGDRGN:DTIME E  W $C(7) S PSGDRGN="^" Q
         Q:"^"[PSGDRGN  S X=$S(PSGDRGN'?.ANP:"Control character(s)",PSGDRGN["^":
          "Up-arrow ('^') in text",$L(PSGDRGN)>39:"Response longer than 39 chara
          cters",1:"") I X]"" W $C(7),"  ??",!?2,"(",X," not allowed.)" G FTD
         Q:PSGDRGN'?1."?"
         W !!?2,"ENTER DRUG ORDERED (1-39 CHARACTERS).",!?2,"Since the drug cann
          ot be found in the DRUG file, enter the drug name here",!,"exactly as 
          ordered.  Press the RETURN key (or enter an '^') to skip over this",!,
          "drug, or to again search the"
         W " DRUG file for this one." G FTD
         ;
TAM      ; Try Again Message
         W !!,"  Enter a 'Y' to try again to find the drug ordered from the Form
          ulary.  (The",!,"order cannot become active until a Formulary drug has
           been entered.)  Enter 'N'",!,"to enter the drug ordered as free text 
          for later reference."
         W "  Enter '^' to exit.",! Q

*****   INDEX OF PSJOE1   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   %            DONE+1!,GDO+1*,GDO+2
>> CHK          OC+5*
   DA           DONE+1!
   DIC          DONE+1!
   DIE          DONE+1!
   DIR          OC+5!
   DIR("A"      OC+5*
   DIR(0        OC+5*
>> DIRUT        OC+5
   DR           EDIT+7*,EDIT+8,DONE+1!
   DRG          DONE+1!
   DRGN         DONE+1!
   DRGO         DONE+1!
   DTIME        FTD+1
   DUZ          AD+12,EDIT+15
>> IOBM         AD+3*
>> IORC         AD+3
>> IOSC         AD+3
   IOSL         AD+3
>> IOSTBM       AD+3
>> IOTM         AD+3*
   ND           DONE+1!
   OC           DONE+1!
   ORIFN        DONE+1!
   ORIT         DONE+1!
   ORPK         DONE+1!
   ORSTOP       DONE+1!
   ORSTRT       DONE+1!
   ORSTS        DONE+1!
   ORTX         DONE+1!
   PC           PSJOE1+7*,EN+1*,AD+7*,DONE+1!
   PROMPT       EDIT~,EDIT+6
>> PSGAT        AD+12*
   PSGDN        AD+33!,OC+6*
   PSGDO        AD+13,EDIT+16,DONE+1!
>> PSGDRG       OC+4,OC+6
>> PSGDRGN      FTD+1*,FTD+2,FTD+3
>> PSGDT        AD+12,EDIT+15
>> PSGEBN       AD+12*,EDIT+15*
   PSGEDTOI     AD+3~,OC+10,EDIT+12*,DONE+2!
   PSGEFN       AD+10!*
   PSGEFN(      AD+10*
>> PSGFD        AD+14*,EDIT+16
>> PSGFDN       AD+11*
   PSGFDX       AD+3~
>> PSGLI        AD+12*,EDIT+15*
>> PSGLIN       AD+12*,EDIT+15*
   PSGMR        AD+13,EDIT+16,DONE+1!
   PSGMRN       DONE+1!
   PSGNEDFD     DONE+1!
   PSGNEFD      AD+11,AD+13,AD+14,DONE+1!
   PSGNEFDO     AD+3~
   PSGNESD      AD+11,AD+13,AD+14,DONE+1!
>> PSGOEAV      AD+12,AD+27
   PSGOEE       AD+10!,AD+23!,AD+34
   PSGOEEF      AD+10!,AD+35*
>> PSGOEEG      EDIT+6*
>> PSGOEENO     EDIT+7*,EDIT+8,EDIT+9,EDIT+13
>> PSGOEER      EDIT+12
>> PSGOEEWF     EDIT+6*
   PSGOEOS      AD+10!
   PSGOES       EDIT+9,DONE+1!
>> PSGOINST     AD+11*
   PSGORD       AD+23,AD+24,AD+30,AD+32,AD+34,AD+35,AD+37,OC+13,EDIT+17,DONE+1!
   PSGOROE1     AD+9,DONE+1!
   PSGORQF      AD+3~,AD+4!,AD+6,AD+20,OC+2!,OC+9*,OC+13
>> PSGP         AD+30,AD+35,OC+12,EDIT+17
>> PSGPD        AD+11*
>> PSGPDN       AD+11*,AD+29
>> PSGPDRG      AD+11,AD+13,EDIT+16
   PSGS0XT      DONE+1!
   PSGS0Y       AD+12,DONE+1!
   PSGSCH       AD+13,EDIT+16,DONE+1!
>> PSGSD        AD+14*,EDIT+16
>> PSGSDN       AD+11*
   PSGSDX       AD+3~
   PSGSI        DONE+1!
>> PSGST        AD+13,EDIT+16
>> PSGSTAT      AD+12*
>> PSGTDD       AD+30,OC+6*
   PSGX         DONE+1!
   PSJACEPT     AD+15!,AD+16,AD+20*,AD+21,AD+22!
   PSJALGY1     OC+1~,OC+11*
   PSJALLGY     OC+1~
   PSJDD        OC+1~,OC+9*,OC+12,OC+13
>> PSJNEWOE     EDIT+6,EDIT+7,EDIT+8
>> PSJNOO       AD+21*,AD+22
   PSJNORD      AD+3~*
   PSJOCFG      AD+2!,AD+3~*,AD+37,DONE+2!
>> PSJORD       AD+23*
>> PSJORQF      AD+6*,AD+7*
>> PSJSYSP0     AD+8
>> PSJSYSU      AD+34
   PSJYSCL      AD+33!
   U            AD+11,AD+12,AD+13,AD+37,EDIT+15,EDIT+16
>> VALM("TM"    AD+3
>> VALMBCK      AD+15*,EDIT+7*,EDIT+8*
   VALMSG       EDIT+13!,EDIT+14*
>> X            AD+7,AD+10*,OC+6,FTD+2*
   Y            AD+15,EDIT+6,DONE+1!
   Z            DONE+1!

Global Variables  ( * Changed  ! Killed)
   ^PS(53.1            AD+37
   ^PS(55              AD+30*
   ^PSDRUG("ACLOZ"     OC+4
   ^TMP("PSODAOC"      AD+24*

Naked Globals
   NONE

Cache Objects
   NONE

Marked Items
   NONE

Label References
   @(           EDIT+6
   AD           PSJOE1+7,AD+7,AD+9,AD+22,AD+27,AD+38
   DONE         AD+6,OC+5
   FTD          FTD+2,FTD+5
   OC           AD+17
   TAM          GDO+1

External References
   YN^DICN             GDO+1
   ^DIR                OC+5
   $$ENDD^PSGMI        AD+11,AD+12,EDIT+15
   $$ENDTC^PSGMI       AD+11,AD+12,EDIT+15
   $$ENNPN^PSGMI       AD+12,EDIT+15
   ^PSGOE1             AD+35
   ^PSGOE3             AD+8
   ^PSGOE4             AD+8
   ^PSGOE7             AD+5
   CHKDD^PSGOEE        EDIT+14
   EDIT^PSGOEE         EDIT+6
   GTSTATUS^PSGOEE     EDIT+14
   ENNOU^PSGOEE0       EDIT+8,EDIT+9
   ENSFE^PSGOEE0       AD+35
   ^PSGOES             AD+7
   ^PSGOETO            AD+23
   CHK^PSGOEV          AD+13,EDIT+16
   EN^PSGPEN           AD+34
   ENDDC^PSGSICHK      OC+12
   GETUD^PSJLMGUD      AD+35
   INIT^PSJLMUDE       EDIT+17
   $$OINAME^PSJLMUTL   AD+11
   $$DD53P45^PSJMISC   OC+9
   SETOC^PSJNEWOC      AD+32,AD+37
   IN^PSJOCDS          OC+13
   CLOZSND^PSJOE       AD+33
   $$ENNOO^PSJUTL5     AD+21
   EN^VALM             AD+15,AD+35
   FULL^VALM1          OC+8

*****   END   *****


PSJRXLAB * *  121 Lines,  7791 Bytes, Checksum: B47487387
                                                  Jul 01, 2016@13:24:55 page 23
              1115 bytes in comments
PSJRXLAB ;ALB/RTW -  drug+lab result print ; 03/25/2016 10:06
         ;;5.0;INPATIENT PHARMACY;**327**;DEC 1997;Build 10
         ;RTW copied from routine PSORXLAB and modified for the Inpatient NCC Cl
          ozapine inpatient pharmacy project
         ;FSIG and FSIG2(formerly EN2), are brought in from PSOUTLA and PSOUTLA1
           
         ;a routine which loop thru the last fill order of ^PS(55 and gets
         ;patients with a specific drug. then gets the lrdfn from the 
         ;patient file and loops thru the patients lab data to find
         ;results within the date range you specify for the lab test
         ;used to minitor the drug. it then prints the patient's name
         ;ssn, last fill date, and the lab test results if any.
         ;this is intended as a qa minitor and should not be run for
         ;more than a 30 day fill date interval, or 1 year lab test interval.
         ;External ref. to ^LAB(60, is supp. by DBIA# 333
         ;External ref. to ^LR(LRDFN,"CH", is supp. by DBIA# 844
         ;External ref. to ^PSDRUG( is supp. by DBIA# 221
         ;External ref. to ^VA(200, is supp. by DBIA# 10060
PSJSITE  K ^UTILITY("DIQ1",$J),DIQ S DA=$P($$SITE^VASITE(),"^")
         N PSCNT
         S PSCNT=0
         I $G(DA) D
         .S DIC=4,DIQ(0)="I",DR=".01;99" D EN^DIQ1
         .S SITE=$G(^UTILITY("DIQ1",$J,4,DA,.01,"I"))_" "_$G(^UTILITY("DIQ1",$J,
          4,DA,99,"I"))
         .K ^UTILITY("DIQ1",$J),DA,DR,DIQ,DIC
         S Y=DT X ^DD("DD") S SITE=$G(SITE)_" "_Y
BDATE    S %DT="EXTA",%DT("A")="Beginning fill date: " D ^%DT G CLEAN:Y<0 S PSJB
          D=Y X ^DD("DD") S PSJBDR=Y
EDATE    S %DT("A")="Ending last fill date: " D ^%DT G CLEAN:Y<0 S PSJED=Y X ^DD
          ("DD") S PSJEDR=Y
LDATE    S %DT("A")="Earliest date for lab results: " D ^%DT G CLEAN:Y<0 S LDATE
          =Y X ^DD("DD") S LDATER=Y
DRUG     R !,"Enter the key word in the Drug Generic name: ",PSJDRUG:DTIME G CLE
          AN:'$T I "^"[PSJDRUG G CLEAN
         I $O(^PSDRUG("B",$E(PSJDRUG,1,$L(PSJDRUG)-1)))'[PSJDRUG W !,"No corresp
          onding entry, try again or type return to exit" G DRUG
LABT     S DIC="^LAB(60,",DIC(0)="QEAM" D ^DIC K DIC G:Y<0 CLEAN S PSJLBT=$P(Y,"
          ^"),PSJLABTN=$P(Y,"^",2) G:PSJLBT="" CLEAN I $G(^LAB(60,PSJLBT,.2))']"
          " W !!,$C(7),"Data Name missing !!",! K Y,PSJLBT G LABT
         S PSJLABT=^LAB(60,PSJLBT,.2)
         W !,"Enter the specimen used in the lab for this test, serum,plasma,blo
          od etc."
PSJSP    S DIC="^LAB(61,",DIC(0)="QEAM" D ^DIC G:Y<0 CLEAN S PSJSP=$P(Y,"^") G:P
          SJSP="" CLEAN ;;I $P($G(^LAB(60,PSJLBT,1,PSJSP,0)),"^",7)']"" W !!,$C(
          7),"Specimen data missing !!",! ;K Y,PSJSP G PSJSP
PSJUNIT  S PSJUNIT=$S($G(PSJSP)]"":$P($G(^LAB(60,PSJLBT,1,PSJSP,0)),"^",7),1:"")
PSJANS   R !,"Do you want Order info? N// ",PSJANS:DTIME G CLEAN:'$T S:PSJANS=""
           PSJANS="N" G:PSJANS="^" CLEAN2 I "YN"'[PSJANS W !,"ANSWER YES OR NO" 
          G PSJANS
DEVICE   K IOP S %ZIS="MQ" D ^%ZIS G:POP CLEAN2
         I $D(IO("Q")) K IO("Q") S ZTSAVE("*")="",ZTRTN="DQ^PSJRXLAB",ZTDESC="LA
          B LIST" D ^%ZTLOAD K ZTSK G CLEAN
DQ       S PSJLABQ=0 S PSJBD=PSJBD-1,PAGE=0 U IO W @IOF D HDR
LOOP1    N PSJ F PSJ=0:0 S PSJBD=$O(^OR(100,"AD",PSJBD)) Q:PSJBD=""!($G(PSJLABQ)
          )  Q:PSJBD>PSJED  S PSJORDN=0 D LOOP2
         G CLEAN
LOOP2    N PSJ2 F PSJ2=0:0 S PSJORDN=$O(^OR(100,"AD",PSJBD,PSJORDN)) Q:PSJORDN="
          "!($G(PSJLABQ))  D:$G(^OR(100,PSJORDN,0))]"" CHECK1
         Q
CHECK1   ;
         N PSJNUM
         S PSCNT=PSCNT+1
         S ^TMP("ORDERNUM",PSCNT)=PSJORDN
         S PSJNUM=0 F  S PSJNUM=$O(^OR(100,PSJORDN,4.5,PSJNUM)) Q:'PSJNUM  D
         . I $P(^OR(100,PSJORDN,4.5,PSJNUM,0),"^",4)["DRUG" D
         . . S PSJDGN=$P($G(^OR(100,PSJORDN,4.5,PSJNUM,1)),"^",1),PSJDRUGN=$P($G
          (^PSDRUG(PSJDGN,0)),"^")
         Q:'$D(PSJDGN)
         I PSJDRUGN'[PSJDRUG Q
         Q:'$P($G(^OR(100,PSJORDN,0)),"^",4)  S PSJPROV=$P(^OR(100,PSJORDN,0),"^
          ",4),PSJPROVN=$P(^VA(200,PSJPROV,0),"^"),PSJPROT=$P(^VA(200,PSJPROV,0)
          ,"^",5)
         S PSJTYPE="NONE" I PSJPROT S PSJTYPE=$P("FULL TIME^PART TIME^C & A^FEE^
          STAFF","^",PSJPROT)
CHECK2   Q:'$P($G(^OR(100,PSJORDN,0)),"^",2)
         S (PSJPT)=+$P(^OR(100,PSJORDN,0),"^",2) W ! D PID^VADPT,PRINT2
         I '$D(^DPT(PSJPT,"LR")) W ?55,"No lab data exists",?81,$E(PSJPROVN,1,20
          ),?106,PSJTYPE,! D:PSJANS["Y" PSJORDNI Q
         S LRDFN=$P(^DPT(PSJPT,"LR"),"^"),PSJLBENT=0,PSJINDIC=0
LOOP3    F J2=0:0 S PSJLBENT=$O(^LR(LRDFN,"CH",PSJLBENT)) Q:PSJLBENT=""!($G(PSJL
          ABQ))  S PSJLDATE=$P(^LR(LRDFN,"CH",PSJLBENT,0),"^") Q:PSJLDATE<LDATE 
           D CHECK3
         I PSJINDIC=0 W ?55,"NO LAB DATA IN RANGE",?81,$E(PSJPROVN,1,20),?106,PS
          JTYPE,!
         D:PSJANS["Y" PSJORDNI
         Q
CHECK3   I $D(^LR(LRDFN,"CH",PSJLBENT,PSJLABT)) D RESULT
         Q
RESULT   Q:$P(^LR(LRDFN,"CH",PSJLBENT,0),"^",5)'=PSJSP  Q:'$P(^(0),"^",3)
         S Y=PSJLDATE X ^DD("DD") W ?55,$E(Y,1,11),?70,$P(^LR(LRDFN,"CH",PSJLBEN
          T,PSJLABT),"^")_" "_PSJUNIT,?81,$E(PSJPROVN,1,20),?106,PSJTYPE W !
         S PSJINDIC=1 Q
         Q
PRINT2   I $Y>(IOSL-6) D  Q:$G(PSJLABQ)  W @IOF,SITE,! D HDR2
         .I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR S:$D(DTOUT)!($D(DUOUT)) PSJLA
          BQ=1
         W ?1,$E($P(^DPT(PSJPT,0),"^"),1,20),?25,VA("PID") S Y=PSJBD X ^DD("DD")
           W ?43,Y Q
HDR      W SITE,!!,"Patients receiving "_PSJDRUG_" with fills between "_PSJBDR_"
           and "_PSJEDR,!," with date of collection and results for lab test "_P
          SJLABTN_" after ",LDATER,!
HDR2     S PAGE=PAGE+1 W !,"Name",?25,"ID#",?43,"Fill Date",?55,"Lab Date",?71,"
          Results",?81,"Order Provider",?106,"Type",?116,"Page "_PAGE,!
         F J=1:1:IOM-1 W "_"
         W ! Q
PSJORDNI N DTOUT,DUOUT Q:$G(PSJLABQ)  W "Order #: "_$P(^OR(100,PSJORDN,0),"^")_"
             Drug: "_$P(^PSDRUG(PSJDGN,0),"^")
         K FSIG,BSIG I $P($G(^OR(100,PSJORDN,4.5,5,1)),"^") D FSIG("O",PSJORDN,7
          2) F PSREV=1:1 Q:'$D(FSIG(PSREV))  S BSIG(PSREV)=FSIG(PSREV)
         K FSIG,PSREV I '$P($G(^OR(100,PSJORDN,4.5,5,1)),"^") D FSIG2(PSJORDN,72
          )
         W !?1,"Sig: ",$G(BSIG(1))
         I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV  W !?6,$G(BS
          IG(PSREV))
         I $Y>(IOSL-6) D  Q:$G(PSJLABQ)  W @IOF,SITE,! D HDR2
         .I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR S:$D(DTOUT)!($D(DUOUT)) PSJLA
          BQ=1
         W ! Q
CLEAN    W @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
CLEAN2   K PSJINDIC,PSJPT,PSJLDATE,PAGE,PSJBD,PSJBDR,PSJLBENT,PSJLABT,PSJDGN,PSJ
          DRUGN,PSJDRUG,J,J1,J2,PSJORDN,PSJPROV,PSJPROVN,LDATE,LDATER,PSJED,PSJE
          DR,PSJPROT,PSJTYPE,PSJLABTN,PSJLBT,PSJSP,PSJUNIT,PSJANS,DIC,LRDFN,POP,
          SITE,Y,%DT,PSJLABQ
         K ZTDESC,ZTRTN,ZTSAVE,%ZIS,^TMP("ORDERNUM") Q
FSIG(PSJFILE,PSJINTR,PSJLENTH) --
          ;Format front door sig
         ;PSJFILE is 'P' if in Pending File, 'R' if in Prescription File
         ;PSJINTR is internal number for either file
         ;PSJLENTH is length of each line of the Sig
         ;returned in the FSIG array
         K FSIG I $G(PSJFILE)=""!('$G(PSJINTR))!('$G(PSJLENTH)) G FQUIT
         I PSJFILE'="P",PSJFILE'="O" G FQUIT
         I PSJFILE="P",'$D(^PS(52.41,+PSJINTR,0)) G FQUIT
         I PSJFILE="O",'$D(^OR(100,+PSJINTR,0)) G FQUIT
         I PSJFILE="O",'$P($G(^OR(100,+PSJINTR,"SIG")),"^",2) G FQUIT
         N FFF,NNN,CNT,FVAR,FVAR1,FLIM,HSIG,II
         I PSJFILE="P" F NNN=0:0 S NNN=$O(^PS(52.41,PSJINTR,"SIG",NNN)) Q:'NNN  
          S:$G(^(NNN,0))'="" HSIG(NNN)=^(0)
         I PSJFILE="P" G:'$O(HSIG(0)) FQUIT G FSTART
         S FFF=1 F NNN=0:0 S NNN=$O(^OR(100,PSJINTR,"SIG1",NNN)) Q:'NNN  I $G(^(
          NNN,0))'="" S HSIG(FFF)=^(0) S FFF=FFF+1
         G:'$O(HSIG(0)) FQUIT
FSTART   S (FVAR,FVAR1)="",II=1
         F FFF=0:0 S FFF=$O(HSIG(FFF)) Q:'FFF  S CNT=0 F NNN=1:1:$L(HSIG(FFF)) I
           $E(HSIG(FFF),NNN)=" "!($L(HSIG(FFF))=NNN) S CNT=CNT+1 D  I $L(FVAR)>P
          SJLENTH S FSIG(II)=FLIM_" ",II=II+1,FVAR=FVAR1
         .S FVAR1=$P(HSIG(FFF)," ",(CNT))
         .S FLIM=FVAR
         .S FVAR=$S(FVAR="":FVAR1,1:FVAR_" "_FVAR1)
         I $G(FVAR)'="" S FSIG(II)=FVAR
         I $G(FSIG(1))=""!($G(FSIG(1))=" ") S FSIG(1)=$G(FSIG(2)) K FSIG(2)
FQUIT    Q
FSIG2(PSJBINTR,PSJBLGTH) --
          ;
         K BSIG
         N BBSIG,BVAR,BVAR1,III,CNT,NNN,BLIM
         S BBSIG=$P($G(^OR(100,PSJBINTR,"SIG")),"^") Q:BBSIG=""!($P($G(^("SIG"))
          ,"^",2))
         S (BVAR,BVAR1)="",III=1
         S CNT=0 F NNN=1:1:$L(BBSIG) I $E(BBSIG,NNN)=" "!($L(BBSIG)=NNN) S CNT=C
          NT+1 D  I $L(BVAR)>PSJBLGTH S BSIG(III)=BLIM_" ",III=III+1,BVAR=BVAR1
         .S BVAR1=$P(BBSIG," ",(CNT))
         .S BLIM=BVAR
         .S BVAR=$S(BVAR="":BVAR1,1:BVAR_" "_BVAR1)
         I $G(BVAR)'="" S BSIG(III)=BVAR
         I $G(BSIG(1))=""!($G(BSIG(1))=" ") S BSIG(1)=$G(BSIG(2)) K BSIG(2)
         Q
         ;

*****   INDEX OF PSJRXLAB   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   %DT          BDATE*,CLEAN2!
   %DT("A"      BDATE*,EDATE*,LDATE*
   %ZIS         DEVICE*,CLEAN2+1!
   BBSIG        FSIG2+2~,FSIG2+3*,FSIG2+5,FSIG2+6
   BLIM         FSIG2+2~,FSIG2+5,FSIG2+7*
   BSIG         PSJORDNI+1!,FSIG2+1!
   BSIG(        PSJORDNI+1*,PSJORDNI+4,FSIG2+5*,FSIG2+9*
   BSIG(1       PSJORDNI+3,PSJORDNI+4,FSIG2+10*
   BSIG(2       FSIG2+10!
   BVAR         FSIG2+2~,FSIG2+4*,FSIG2+5*,FSIG2+7,FSIG2+8*,FSIG2+9
   BVAR1        FSIG2+2~,FSIG2+4*,FSIG2+5,FSIG2+6*,FSIG2+8
   CNT          FSIG+10~,FSTART+1*,FSTART+2,FSIG2+2~,FSIG2+5*,FSIG2+6
   DA           PSJSITE*,PSJSITE+3,PSJSITE+5,PSJSITE+6!
   DIC          PSJSITE+4*,PSJSITE+6!,LABT*!,PSJSP*,CLEAN2!
   DIC(0        LABT*,PSJSP*
   DIQ          PSJSITE!,PSJSITE+6!
   DIQ(0        PSJSITE+4*
   DIR          PRINT2+1!,PSJORDNI+6!
   DIR(0        PRINT2+1*,PSJORDNI+6*
   DR           PSJSITE+4*,PSJSITE+6!
   DT           PSJSITE+7
   DTIME        DRUG,PSJANS
   DTOUT        PRINT2+1,PSJORDNI~,PSJORDNI+6
   DUOUT        PRINT2+1,PSJORDNI~,PSJORDNI+6
   FFF          FSIG+10~,FSIG+13*,FSTART+1*,FSTART+2
   FLIM         FSIG+10~,FSTART+1,FSTART+3*
   FSIG         PSJORDNI+1!,PSJORDNI+2!,FSIG+5!
   FSIG(        PSJORDNI+1,FSTART+1*,FSTART+5*
   FSIG(1       FSTART+6*
   FSIG(2       FSTART+6!
   FVAR         FSIG+10~,FSTART*,FSTART+1*,FSTART+3,FSTART+4*,FSTART+5
   FVAR1        FSIG+10~,FSTART*,FSTART+1,FSTART+2*,FSTART+4
   HSIG         FSIG+10~
   HSIG(        FSIG+11*,FSIG+13*,FSTART+1,FSTART+2
   HSIG(0       FSIG+12,FSIG+14
   II           FSIG+10~,FSTART*,FSTART+1*,FSTART+5
   III          FSIG2+2~,FSIG2+4*,FSIG2+5*,FSIG2+9
   IO           DQ
   IO("Q"       DEVICE+1!
   IOF          DQ,PRINT2,PSJORDNI+5,CLEAN
   IOM          HDR2+1
   IOP          DEVICE!
   IOSL         PRINT2,PSJORDNI+5
   IOST         PRINT2+1,PSJORDNI+6
   J            HDR2+1*,CLEAN2!
   J1           CLEAN2!
   J2           LOOP3*,CLEAN2!
   LDATE        LDATE*,LOOP3,CLEAN2!
   LDATER       LDATE*,HDR,CLEAN2!
   LRDFN        CHECK2+3*,LOOP3,CHECK3,RESULT,RESULT+1,CLEAN2!
   NNN          FSIG+10~,FSIG+11*,FSIG+13*,FSTART+1*,FSIG2+2~,FSIG2+5*
   PAGE         DQ*,HDR2*,CLEAN2!
   POP          DEVICE,CLEAN2!
   PSCNT        PSJSITE+1~,PSJSITE+2*,CHECK1+2*,CHECK1+3
   PSJ          LOOP1~*
   PSJ2         LOOP2~*
   PSJANS       PSJANS*,CHECK2+2,LOOP3+2,CLEAN2!
   PSJBD        BDATE*,DQ*,LOOP1*,LOOP2,PRINT2+2,CLEAN2!
   PSJBDR       BDATE*,HDR,CLEAN2!
   PSJBINTR     FSIG2~,FSIG2+3
   PSJBLGTH     FSIG2~,FSIG2+5
   PSJDGN       CHECK1+6*,CHECK1+7,PSJORDNI,CLEAN2!
   PSJDRUG      DRUG*,DRUG+1,CHECK1+8,HDR,CLEAN2!
   PSJDRUGN     CHECK1+6*,CHECK1+8,CLEAN2!
   PSJED        EDATE*,LOOP1,CLEAN2!
   PSJEDR       EDATE*,HDR,CLEAN2!
   PSJFILE      FSIG~,FSIG+5,FSIG+6,FSIG+7,FSIG+8,FSIG+9,FSIG+11,FSIG+12
   PSJINDIC     CHECK2+3*,LOOP3+1,RESULT+2*,CLEAN2!
   PSJINTR      FSIG~,FSIG+5,FSIG+7,FSIG+8,FSIG+9,FSIG+11,FSIG+13
   PSJLABQ      DQ*,LOOP1,LOOP2,LOOP3,PRINT2,PRINT2+1*,PSJORDNI,PSJORDNI+5
                PSJORDNI+6*,CLEAN2!
   PSJLABT      LABT+1*,CHECK3,RESULT+1,CLEAN2!
   PSJLABTN     LABT*,HDR,CLEAN2!
   PSJLBENT     CHECK2+3*,LOOP3*,CHECK3,RESULT,RESULT+1,CLEAN2!
   PSJLBT       LABT*!,LABT+1,PSJUNIT,CLEAN2!
   PSJLDATE     LOOP3*,RESULT+1,CLEAN2!
   PSJLENTH     FSIG~,FSIG+5,FSTART+1
   PSJNUM       CHECK1+1~,CHECK1+4*,CHECK1+5,CHECK1+6
   PSJORDN      LOOP1*,LOOP2*,CHECK1+3,CHECK1+4,CHECK1+5,CHECK1+6,CHECK1+9
                CHECK2,CHECK2+1,PSJORDNI,PSJORDNI+1,PSJORDNI+2,CLEAN2!
   PSJPROT      CHECK1+9*,CHECK1+10,CLEAN2!
   PSJPROV      CHECK1+9*,CLEAN2!
   PSJPROVN     CHECK1+9*,CHECK2+2,LOOP3+1,RESULT+1,CLEAN2!
   PSJPT        CHECK2+1*,CHECK2+2,CHECK2+3,PRINT2+2,CLEAN2!
   PSJSP        PSJSP*,PSJUNIT,RESULT,CLEAN2!
   PSJTYPE      CHECK1+10*,CHECK2+2,LOOP3+1,RESULT+1,CLEAN2!
   PSJUNIT      PSJUNIT*,RESULT+1,CLEAN2!
   PSREV        PSJORDNI+1*,PSJORDNI+2!,PSJORDNI+4*
   SITE         PSJSITE+5*,PSJSITE+7*,PRINT2,HDR,PSJORDNI+5,CLEAN2!
>> VA("PID"     PRINT2+2
   Y            PSJSITE+7*,BDATE,EDATE,LDATE,LABT!,PSJSP,RESULT+1*,PRINT2+2*
                CLEAN2!
   ZTDESC       DEVICE+1*,CLEAN2+1!
>> ZTQUEUED     CLEAN
>> ZTREQ        CLEAN*
   ZTRTN        DEVICE+1*,CLEAN2+1!
   ZTSAVE       CLEAN2+1!
   ZTSAVE("*"   DEVICE+1*
   ZTSK         DEVICE+1!

Global Variables  ( * Changed  ! Killed)
   ^DD("DD"            PSJSITE+7,BDATE,EDATE,LDATE,RESULT+1,PRINT2+2
   ^DPT(               CHECK2+2,CHECK2+3,PRINT2+2
   ^LAB(60             LABT,LABT+1,PSJUNIT
   ^LR(                LOOP3,CHECK3,RESULT,RESULT+1
   ^OR(100             LOOP1,LOOP2,CHECK1+4,CHECK1+5,CHECK1+6,CHECK1+9,CHECK2
                       CHECK2+1,PSJORDNI,PSJORDNI+1,PSJORDNI+2,FSIG+8,FSIG+9
                       FSIG+13,FSIG2+3
   ^PS(52.41           FSIG+7,FSIG+11
   ^PSDRUG(            CHECK1+6,PSJORDNI
   ^PSDRUG("B"         DRUG+1
   ^TMP("ORDERNUM"     CHECK1+3*,CLEAN2+1!
   ^UTILITY("DIQ1"     PSJSITE!,PSJSITE+5,PSJSITE+6!
   ^VA(200             CHECK1+9

Naked Globals
   ^(           FSIG+11,FSIG+13
   ^("SIG"      FSIG2+3
   ^(0          RESULT,FSIG+11,FSIG+13

Cache Objects
   NONE

Marked Items
   NONE

Label References
   CHECK1       LOOP2
   CHECK3       LOOP3
   CLEAN        BDATE,EDATE,LDATE,DRUG,LABT,PSJSP,PSJANS,DEVICE+1,LOOP1+1
   CLEAN2       PSJANS,DEVICE
   DRUG         DRUG+1
   FQUIT        FSIG+5,FSIG+6,FSIG+7,FSIG+8,FSIG+9,FSIG+12,FSIG+14
   FSIG         PSJORDNI+1
   FSIG2        PSJORDNI+2
   FSTART       FSIG+12
   HDR          DQ
   HDR2         PRINT2,PSJORDNI+5
   LABT         LABT
   LOOP2        LOOP1
   PRINT2       CHECK2+1
   PSJANS       PSJANS
   PSJORDNI     CHECK2+2,LOOP3+2
   RESULT       CHECK3

External References
   ^%DT                BDATE,EDATE,LDATE
   ^%ZIS               DEVICE
   ^%ZISC              CLEAN
   ^%ZTLOAD            DEVICE+1
   ^DIC                LABT,PSJSP
   EN^DIQ1             PSJSITE+4
   ^DIR                PRINT2+1,PSJORDNI+6
   PID^VADPT           CHECK2+1
   $$SITE^VASITE       PSJSITE

*****   END   *****


|dd53.8  * *  23 Lines,  566 Bytes, Checksum:     Jul 01, 2016@13:24:55 page 24
              269 bytes in comments
|dd53.8  ;DD of the CLOZAPINE MEDICATION OVERRIDES file.
.01      ; DATE TIME
         S %DT="ESTXR" D ^%DT S X=Y K:X<1 X
.01XRF1S ; SET LOGIC FOR 'B' XREF
         S ^PS(53.8,"B",$E(X,1,30),DA)=""
.01XRF1K ; KILL LOGIC FOR 'B' XREF
         K ^PS(53.8,"B",$E(X,1,30),DA)
1        ; ORDER NUMBER
         Q
1XRF1S   ; SET LOGIC FOR 'A' XREF
         S ^PS(53.8,"A",$E(X,1,30),DA)=""
1XRF1K   ; KILL LOGIC FOR 'A' XREF
         K ^PS(53.8,"A",$E(X,1,30),DA)
2        ; USER ENTERING
         Q
3        ; APPROVING TEAM MEMBER
         Q
4        ; REASON FOR OVERRIDE
         Q
5        ; COMMENTS
         K:$L(X)>200!($L(X)<5) X
6        ; SECOND APPROVING TEAM MEMBER
         Q

*****   INDEX OF |dd53.8   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
>> %DT          .01+1*
>> DA           .01XRF1S+1,.01XRF1K+1,1XRF1S+1,1XRF1K+1
   X            .01+1*!,.01XRF1S+1,.01XRF1K+1,1XRF1S+1,1XRF1K+1,5+1!
>> Y            .01+1

Global Variables  ( * Changed  ! Killed)
   ^PS(53.8            .01XRF1S+1*,.01XRF1K+1!,1XRF1S+1*,1XRF1K+1!

Naked Globals
   NONE

Cache Objects
   NONE

Marked Items
   NONE

Label References
   NONE

External References
   ^%DT                .01+1

*****   END   *****


|dd55.06 * *  3 Lines,  120 Bytes, Checksum:      Jul 01, 2016@13:24:55 page 25
              61 bytes in comments
|dd55.06 ;Partial DD of the UNIT DOSE file.
301      ; CLOZAPINE DOSAGE (MG/DAY)
         K:+X'=X!(X>3000)!(X<0)!(X?.E1"."1N.N) X

*****   INDEX OF |dd55.06   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   X            301+1!

Global Variables  ( * Changed  ! Killed)
   NONE

Naked Globals
   NONE

Cache Objects
   NONE

Marked Items
   NONE

Label References
   NONE

External References
   NONE

*****   END   *****


|opt     * *  80 Lines,  2438 Bytes, Checksum:    Jul 01, 2016@13:24:55 page 26
              1704 bytes in comments
|opt     ; 'Build file' Options.
         ;
2921784  ; PSJL MANAGER - Clozapine Inpatient Medications Manager (menu) - Locke
          d by PSOLOCKCLOZ
2921742  ; PSJLAB LIST - Display Inpatient Lab Tests and Results (run routine)
         ; ROUTINE
         D ^PSJRXLAB
2921744  ; PSJLIST OVERRIDES - List Inpatient Clozapine Overrides (run routine)
         ; ROUTINE
         D ^PSJCLOLS
1847     ; PSJU MGR - Unit Dose Medications (menu)
         ; EXIT ACTION
         D ENKV^PSGSETU
         ; ENTRY ACTION
         D ^PSGSET
2911816  ; PSOL REGISTER PATIENT - Register Clozapine Patient (run routine)
         ; ROUTINE
         D REG^PSOCLUTL
2911821  ; PSOL EDIT - Edit Data for a Patient in the Clozapine Program (run rou
          tine)
         ; ROUTINE
         D AGAIN^PSOCLUTL
2333     ; PSJU INQMGR - INQuiries Menu (menu)
2536     ; PSJU INQMGR - Inquiries Menu (menu)
2334     ; PSJU REPORTS - Reports Menu (menu)
6141     ; PSJ PR - Inpatient Profile (run routine)
         ; EXIT ACTION
         K DRGN,I1,NF,OD,ON55,PDRG,PSIVAC,PSIVUP,PSJORIFN,UL80,PSJNODIS
         ; ENTRY ACTION
         S PSJNODIS=1
         ; ROUTINE
         D ^PSJPR
6142     ; PSJ OE - Inpatient Order Entry (run routine)
         ; EXIT ACTION
         D KILL^XUSCLEAN
         ; ROUTINE
         D EN^PSJOE
2913627  ; PSJ UEUP - Edit Inpatient User Parameters (run routine)
         ; ROUTINE
         D ENUUEP^PSGFILD0
2913635  ; PSJU AL - Align Labels (Unit Dose) (run routine)
         ; ROUTINE
         D ENAL^PSGLBA
1849     ; PSJU PR - PAtient Profile (Unit Dose) (run routine)
         ; EXIT ACTION
         K PSJNODIS
         ; ENTRY ACTION
         S PSJNODIS=1
         ; ROUTINE
         D ^PSGPR
1871     ; PSJU VBW - Non-Verified/Pending Orders (run routine)
         ; EXIT ACTION
         D KILL^XUSCLEAN
         ; ENTRY ACTION
         ; ROUTINE
         D ^PSGVBW
1848     ; PSJU NE - Order Entry (run routine)
         ; ROUTINE
         D ^PSGOE
1857     ; PSJU PLMGR - PIck List Menu (menu) - Locked by PSJU PL
1864     ; PSJU FILE - Supervisor's Menu (menu) - Locked by PSJU MGR
         ; ENTRY ACTION
         D BRJCHK^PSGSET
1870     ; PSJU LABEL - Label Print/Reprint (run routine)
         ; ROUTINE
         D ^PSGL
1872     ; PSJU CA - Discontinue All of a Patient's Orders (run routine)
         ; ROUTINE
         D ^PSGOECA
2349     ; PSJU HOLD ALL - Hold All of a Patient's Orders (run routine) - Locked
           by PSJU RPH
         ; ROUTINE
         D EN^PSGOEHA
2538     ; PSJU CPDD - Edit Patient's Default Stop Date (run routine) - Locked b
          y PSJU PL
         ; ROUTINE
         D ENCPDD^PSGFILED
2921577  ; PSJ CHECK DRUG INTERACTION - Check Drug Interaction (run routine)
         ; ROUTINE
         D PSSDGCK^PSJUTL1
2921599  ; PSJ ECO - Edit Clinic Med Orders Start Date/Time (run routine)
         ; ENTRY ACTION
         ; ROUTINE
         D START^PSJCLOR

*****   INDEX OF |opt   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   DRGN         6141+2!
   I1           6141+2!
   NF           6141+2!
   OD           6141+2!
   ON55         6141+2!
   PDRG         6141+2!
   PSIVAC       6141+2!
   PSIVUP       6141+2!
   PSJNODIS     6141+2!,6141+4*,1849+2!,1849+4*
   PSJORIFN     6141+2!
   UL80         6141+2!

Global Variables  ( * Changed  ! Killed)
   NONE

Naked Globals
   NONE

Cache Objects
   NONE

Marked Items
   NONE

Label References
   NONE

External References
   ENUUEP^PSGFILD0     2913627+2
   ENCPDD^PSGFILED     2538+2
   ^PSGL               1870+2
   ENAL^PSGLBA         2913635+2
   ^PSGOE              1848+2
   ^PSGOECA            1872+2
   EN^PSGOEHA          2349+2
   ^PSGPR              1849+6
   ^PSGSET             1847+4
   BRJCHK^PSGSET       1864+2
   ENKV^PSGSETU        1847+2
   ^PSGVBW             1871+5
   ^PSJCLOLS           2921744+2
   START^PSJCLOR       2921599+3
   EN^PSJOE            6142+4
   ^PSJPR              6141+6
   ^PSJRXLAB           2921742+2
   PSSDGCK^PSJUTL1     2921577+2
   AGAIN^PSOCLUTL      2911821+2
   REG^PSOCLUTL        2911816+2
   KILL^XUSCLEAN       6142+2,1871+2

*****   END   *****


--- CROSS-REFERENCING ALL ROUTINES ---

*****   Cross Reference of all Routines   *****   Jul 01, 2016@13:24:55 page 27

Local Variables    Routines   ( >> not killed explicitly)
                              ( * Changed  ! Killed  ~ Newed)
   %            PSGNE3,PSGOD*!,PSGOE41*,PSGOE42*,PSGOE7*!,PSGOE8*,PSGOE81*
                PSGOE82*,PSGOE92*,PSGOEF,PSGOER,PSGOESF~,PSGPEN,PSJCLOZ!,PSJCOM
                PSJOE1*!
   %DT          PSGOE41*!,PSGOE81*!,PSGOER!,PSGOER0*!,PSJCLOLS*!,PSJRXLAB*!
                |dd53.8*
   %DT("A"      PSJCLOLS*,PSJRXLAB*
   %DT(0        PSGOE41*,PSGOE81*
   %H           PSGNE3*,PSGOD!
   %I           PSGOD!
>> %T           PSGNE3
   %X           PSGOEV*!,PSJCOM*!
   %Y           PSGOE7!,PSGOEV*!,PSJCOM*!
   %ZIS         PSJCLOLS*,PSJRXLAB*!
   %ZIS("B"     PSJCLOLS*
   A            PSGNE3*~,PSGOT*~
   AA           PSGNE3*~
   AC           PSJOE!
   ACT          PSGOER*~
   ACTION       PSJOE!
>> ANOX         PSGOER0
   ANQDATA      PSJCLOZ!
   ANQREM       PSJCLOZ!
   ANQX         PSGOD,PSGOE42*!,PSGOE7*~,PSGOE8!,PSGOE82*,PSGOE92,PSGOEF*
                PSGOER,PSGOER0!,PSJCLOZ*,PSJOE
   APP          PSGOE7~
>> APPT         PSGNE3,PSJOE*
   AT           PSGNE3*~
>> AT1          PSGNE3*
   B            PSGNE3*~
>> BACK         PSGOE8*,PSGOE81*,PSGOE82*,PSGOE92*
   BBSIG        PSJRXLAB*~
   BLIM         PSJRXLAB*~
   BSIG         PSJRXLAB!
   BSIG(        PSJRXLAB*
   BSIG(1       PSJRXLAB*
   BSIG(2       PSJRXLAB!
   BVAR         PSJRXLAB*~
   BVAR1        PSJRXLAB*~
>> C            PSGOT*
   CHK          PSGOD*,PSGOEF*!,PSGOER*,PSGOEV*!,PSGOEV,PSJCOM*!,PSJOE1*
>> CLINIC       PSJOE*
>> CLOZPAT      PSGNE3,PSGOE41,PSGOE81,PSJCLOZ
   CNT          PSGOE7*~,PSGOT*!,PSJRXLAB*~
   CODE         PSGOESF*~
   COM          PSJOE*~
>> COMQUIT      PSGOER*,PSGOER0*
   CURDAT       PSGOER*~
   CUTOFF       PSGOER*~
   D            PSGOE7*,PSGOE8*!,PSGOER~,PSGOESF*
   D1           PSJOE!
   D2           PSJOE!
   DA           PSGNE3*~,PSGOD!,PSGOE42*!,PSGOE7!,PSGOE82*~,PSGOE92*~,PSGOEF!~
                PSGOER*!~,PSGOESF*!,PSGOEV*!,PSGOT*,PSGOT,PSGPEN*!~,PSJCLOZ*!
                PSJCOM!,PSJOE!,PSJOE1!,PSJRXLAB*!,|dd53.8
   DA(1         PSGOE7*,PSGOER*,PSGOESF*,PSGOEV*,PSGOT*,PSGPEN*
   DA(2         PSGOER*,PSGPEN*
>> DAYS         PSGNE3*
   DD           PSGOER!~,PSJCLOZ!
   DFN          PSGNE3~,PSGOD~,PSGOE41,PSGOE8,PSGOE81,PSGOE92,PSGOEF,PSGOER*~
                PSGOEV~,PSGOT,PSJCLOZ~,PSJOE*~,PSJOE
   DIC          PSGOE42*!,PSGOE7*!,PSGOE8*!,PSGOE82*!~,PSGOE92*!,PSGOER*!~
                PSGOER0*!,PSJCLOZ*!,PSJOE1!,PSJRXLAB*!
   DIC("A"      PSGOE7*
   DIC("DR"     PSGOER*
   DIC("P"      PSGOER*
   DIC("S"      PSGOE42*,PSGOE7*,PSGOE8*,PSGOE82*,PSGOE92*,PSGOER0*
   DIC("T"      PSGOE7*
   DIC(0        PSGOE42*,PSGOE7*,PSGOE8*,PSGOE82*,PSGOE92*,PSGOER*,PSGOER0*
                PSJCLOZ*,PSJRXLAB*
   DIE          PSGOE42*,PSGOE82*~,PSGOE92*~,PSGOEF!,PSGOER*!~,PSGOESF*!
                PSGOEV*!,PSGPEN*,PSJCLOZ*!,PSJCOM!,PSJOE1!
   DIK          PSGNE3*~,PSGOT*!
   DIK(1        PSGNE3*,PSGOT*
>> DILOCKTM     PSGOT
>> DINUM        PSGOER*
   DIQ          PSJRXLAB!
   DIQ(0        PSJRXLAB*
   DIR          PSGOD!,PSGOE7!,PSGOE82~,PSGOEF!~,PSGOER!,PSGOESF!~,PSGOEV!~
                PSGPEN!~,PSJCLOZ!,PSJCOM!~,PSJOE!~,PSJOE1!,PSJRXLAB!
   DIR("?"      PSGOEF*,PSGOER*,PSGOESF*,PSGPEN*
   DIR("??"     PSGOESF*
   DIR("A"      PSGOD*,PSGOE7*,PSGOEF*,PSGOER*,PSGOESF*,PSGOEV*,PSGPEN*
                PSJCLOZ*,PSJCOM*,PSJOE1*
   DIR("B"      PSGOER*,PSGOEV*,PSGPEN*,PSJCLOZ*,PSJCOM*
   DIR(0        PSGOD*,PSGOE7*,PSGOEF*,PSGOER*,PSGOESF*,PSGOEV*,PSGPEN*
                PSJCLOZ*,PSJCOM*,PSJOE*,PSJOE1*,PSJRXLAB*
   DIROUT       PSJCLOZ!
   DIRUT        PSGOER*,PSGOESF,PSGOEV!~,PSJCLOZ!,PSJCOM!~,PSJOE1
   DIU          PSJOE!
   DLAYGO       PSJCLOZ*!
   DO           PSGOER!~,PSJCLOZ!
>> DOW          PSGOE8*
   DOWAT        PSGOER~
   DOWDFN       PSGOER~
   DOWFD        PSGOER~
   DOWSCH       PSGOER~
   DOWSD        PSGOER~
   DOWSTR       PSGOER*~
   DP           PSGOEV!,PSJCOM!
   DR           PSGOE42*!,PSGOE82*~,PSGOE92*~,PSGOEF!,PSGOER*!~,PSGOESF*!
                PSGOEV*!,PSGPEN*!,PSJCLOZ*!,PSJCOM!,PSJOE1*!,PSJRXLAB*!
   DR(2         PSGOE42*,PSGOE82*,PSGOE92*
   DRG          PSGOE7~,PSGOEF*!~,PSGOER0,PSGOESF*~,PSGOEV!~,PSGPEN*,PSJOE!
                PSJOE1!
   DRGCNT       PSGOEF*~
   DRGF         PSGOEV*!,PSJCOM*
   DRGI         PSJOE!
   DRGN         PSJOE1!,|opt!
   DRGO         PSJOE1!
   DRUG         PSJCLOZ~
   DT           PSGOE7,PSGOE8,PSGOER0,PSGOEV,PSGPEN*,PSJRXLAB
   DTIME        PSGOE41,PSGOE42,PSGOE7,PSGOE8,PSGOE81,PSGOE82,PSGOE92,PSGOER
                PSGOER0,PSJOE1,PSJRXLAB
   DTOUT        PSGOEV~,PSJRXLAB~
   DUOUT        PSGOER~,PSGOER0,PSGOEV~,PSGPEN*,PSJRXLAB~
   DUR          PSGOE81*~,PSGOEF*~,PSGOER0*!,PSGOEV*~,PSJCOM*~
   DURMIN       PSGOE81*~,PSGOEF*~,PSGOER0*!
   DURON        PSGOEV*~,PSJCOM*
   DURORD       PSJCOM~
   DUZ          PSGOD,PSGOER,PSGOER0,PSGOEV,PSGPEN,PSJCOM,PSJOE1
   ET           PSGNE3!
   EXPDT        PSGOER~
   F            PSGNE3!,PSGOD*!,PSGOE41!,PSGOE42!,PSGOE8!,PSGOE82!,PSGOE92!
                PSGOER0!,PSGOESF*,PSGOEV!,PSJCOM!
   F0           PSGOE41!,PSGOE42!,PSGOE8!,PSGOE82!,PSGOE92!,PSGOER0!
   F1           PSGOE41!,PSGOE42!,PSGOEF*,PSGOER0*!
   F2           PSGOE8*!
   F3           PSGOE41!,PSGOE42!,PSGOE82!,PSGOE92!,PSGOER0!
>> FB           PSGOE41*,PSGOE42,PSGOE81*
   FD           PSGNE3~
   FDSD         PSGOER!
   FFF          PSJRXLAB*~
>> FILE         PSGOER*
   FILE55       PSGOEV*~
   FILE55N0     PSGOEV*~
   FLAG         PSJOE!
   FLIM         PSJRXLAB*~
>> FQ           PSGPEN*
   FQC          PSJOE!
   FREQ         PSGOER*~
   FSIG         PSJRXLAB!
   FSIG(        PSJRXLAB*
   FSIG(1       PSJRXLAB*
   FSIG(2       PSJRXLAB!
   FT           PSGNE3!
   FVAR         PSJRXLAB*~
   FVAR1        PSJRXLAB*~
   H            PSGOE41*~,PSGOE81*~
>> HRS          PSGNE3*
   HSIG         PSJRXLAB~
   HSIG(        PSJRXLAB*
   HSIG(0       PSJRXLAB
   I            PSGOE41*~,PSGOE81*~
   I1           |opt!
   II           PSJRXLAB*~
   III          PSJRXLAB*~
   INFO         PSGNE3*,PSGOE41*~,PSGOE81*~
   INT          PSGNE3*~
   INTERVAL     PSGOER*~
   INTERVEN     PSGOE82*~,PSGOER*~,PSGOESF*~
   IO           PSJCLOLS,PSJRXLAB
   IO("Q"       PSJCLOLS,PSJRXLAB!
>> IOBM         PSJOE*,PSJOE1*
   IOF          PSGOE7,PSJCLOLS,PSJCLOZ,PSJRXLAB
>> IOINHI       PSGOEF
>> IOINORM      PSGOEF
   IOM          PSGOE7,PSJRXLAB
   IOP          PSJRXLAB!
>> IORC         PSJOE,PSJOE1
>> IORVOFF      PSGOEF
>> IORVON       PSGOEF
>> IOS          PSJOE
>> IOSC         PSJOE,PSJOE1
   IOSL         PSJCLOLS,PSJOE,PSJOE1,PSJRXLAB
   IOST         PSGOER,PSJCLOLS,PSJRXLAB
>> IOSTBM       PSJOE,PSJOE1
>> IOTM         PSJOE*,PSJOE1*
   IVSTYP       PSGOER*~
   J            PSJCLOLS*!,PSJRXLAB*!
   J1           PSJRXLAB!
   J2           PSJRXLAB*!
   L1           PSGOESF*~
   L2           PSGOESF*~
   LAST         PSGOER*~
   LASTAT       PSGOER~
   LDATE        PSJRXLAB*!
   LDATER       PSJRXLAB*!
   LI           PSGNE3*~
   LIMIT        PSGOER*~
   LIST         PSGOEV*~
   LN           PSGOT*~
   LNCNT        PSGOT*~
   LOOP         PSGOESF*~
   LRDFN        PSJRXLAB*!
   LSTLNTXT     PSGOT*~
   LSTLNUM      PSGOT*~
   LSTSTR       PSGOER*~
   LT           PSGNE3!
   LYN          PSGOER!
   MAX          PSGOE41*~,PSGOE81*~
   MI           PSJOE!
   MSG          PSGOE8*,PSGOE81*~,PSGOE82*,PSGOE92*,PSGOEF*!
   MSG(1        PSGOE81*
   MSG(2        PSGOE81*
   N            PSGOD*!,PSJOE!
   ND           PSGNE3*,PSGOD*,PSGOER0,PSGOEV!~,PSGOT!,PSGPEN*,PSJCOM!,PSJOE1!
   ND0          PSGOER*~,PSGOT*
>> ND1          PSGOT*
>> ND14         PSGOER*
   ND2          PSGOER*~,PSGOER0*!,PSGOEV~,PSGOT*,PSJOE!
   NDP2         PSJOE*~
   NE           PSJOE!
   NF           PSGOESF!,|opt!
   NNN          PSJRXLAB*~
   NODE0        PSJOE*~
   NOW          PSGOER*~
   NSFF         PSGOEF*!~
   NT           PSGNE3!
   NWALL        PSGNE3*~
   NXTADM       PSGOER*~
   NXTPT        PSJOE*~
   OC           PSJOE1!
   OCCDT        PSGOEF*~
   OD           |opt!
   ODA          PSGOT*!
   OEORD        PSGOEV*~
   OLDON        PSGOD*~
   ON           PSGOE92,PSGOESF*~,PSJCOM,PSJOE*!~
   ON55         PSJOE~,|opt!
>> OND          PSGNE3*
   OOEORD       PSGOEV*~
>> ORCLOZ       PSJCLOZ
   ORCLPAT      PSJCLOZ*~
   ORIFN        PSJOE*~,PSJOE1!
   ORIG         PSGOE81*!
   ORIT         PSJOE1!
   ORL          PSGOEF~
   ORMAX        PSJCLOZ*~
   ORN          PSGOEF*~
>> ORO          PSJCLOZ
   ORPK         PSJOE1!
   ORSTOP       PSJOE1!
   ORSTRT       PSJOE1!
   ORSTS        PSJOE1!
   ORTX         PSJOE1!
>> ORX          PSJCLOZ
   ORY          PSJCLOZ*!
>> ORYS         PSJCLOZ
   OSD          PSGNE3*~
   OSDLI        PSGNE3*!~
   P            PSGOER~
   P(           PSGOER*
   P("PON"      PSJOE*
   P(11         PSGOER
   P(17         PSJOE
   P(2          PSGOER
   P(3          PSJOE
   P(4          PSGOER
   P(9          PSGOER
   P2ND         PSGOE92*~
   P3           PSJOE!
   PAGE         PSJRXLAB*!
   PARENT       PSGOE92*~
   PC           PSJOE1*!
   PDRG         PSGOE7~,|opt!
   PENDCT       PSGOESF*~
   PKF          PSGOE7~
   PKGFLG       PSGOER0*~
   PND0         PSGOEV*~
   PNDON        PSGOE8~
   PNOW         PSJOE!
   POP          PSJCLOLS!,PSJRXLAB!
   PRI          PSJOE!
   PROMPT       PSJOE~,PSJOE1~
   PROV         PSJCLOZ~
>> PS(          PSGOEF*
   PS538        PSJCLOZ*~
   PSBCNT       PSGOER~
   PSBDT        PSGOER!
   PSBFLAG      PSGOER!
   PSBSTR       PSGNE3,PSGOER!
>> PSCDATE      PSJCLOZ*
>> PSCLPAT      PSJCLOZ
   PSCNT        PSJRXLAB*~
   PSG          PSGNE3~,PSGOE41!,PSGOE42!,PSGOE82!,PSGOE92!
   PSG(         PSGNE3*
>> PSG25        PSGOT*
>> PSG26        PSGOT*
>> PSGACT       PSGOEV*,PSJOE*
   PSGAL        PSGOER!,PSGOEV!,PSJCOM!
   PSGAL("C"    PSGOER*,PSGOEV*
   PSGAL("N"    PSJCOM*
   PSGAL531     PSGOEV*~
   PSGALC       PSJCOM~
   PSGALFN      PSGOEV!,PSJCOM!
   PSGALORD     PSJCOM~
   PSGALR       PSGOER!
   PSGAT        PSGOD*,PSGOE41*,PSGOE8*,PSGOE81*,PSGOEF*,PSGOER~,PSGOEV,PSJCOM
                PSJOE1*
   PSGBCADM     PSGNE3*~
   PSGBCFR      PSGNE3*~
   PSGBCLA      PSGNE3*~
   PSGBCLDT     PSGNE3*~
   PSGBCLHH     PSGNE3*~
   PSGBCLID     PSGNE3*~
   PSGBCLIT     PSGNE3*~
>> PSGBCND      PSGNE3*
>> PSGBCORD     PSGNE3*
>> PSGBCOT      PSGNE3*
>> PSGBCPO      PSGNE3*
>> PSGBCPRV     PSGNE3*
   PSGBCSCD     PSGNE3*~
>> PSGBCSCH     PSGNE3*
   PSGBCSHH     PSGNE3*~
   PSGBCTDA     PSGNE3*~
   PSGBCTDD     PSGNE3*~
   PSGBCTDY     PSGNE3*~
   PSGBCTMP     PSGNE3*!
   PSGBCTMP(    PSGNE3*
   PSGBDNXT     PSGNE3*~
   PSGBNAT      PSGNE3*~
   PSGBSAT      PSGNE3*~
   PSGBSATN     PSGNE3*~
   PSGBST       PSGNE3*~
   PSGBTT       PSGNE3*~
   PSGCANFL     PSGOD*,PSGOEF*,PSGOER*,PSGOEV*,PSJOE!
   PSGCF        PSJOE!
   PSGCFLG      PSGOE41*!,PSGOE81*!
   PSGCOPY      PSGOEV,PSJOE*!
>> PSGDA        PSGPEN*
   PSGDAYC      PSGNE3*~
   PSGDDI       PSGOER*,PSGOESF*,PSGOEV*~
   PSGDFLG      PSGOEV*!
   PSGDGCKF     PSGOE7*~
>> PSGDI        PSGOEV*
   PSGDICS      PSGOE7*!
   PSGDL        PSGNE3*!,PSGOE41*,PSGOE81*,PSGOER!,PSGOER0*!
   PSGDLS       PSGOE41!,PSGOE81!,PSGOER!,PSGOER0!
   PSGDN        PSGOEV*~,PSGPEN*~,PSJOE,PSJOE1*!
   PSGDO        PSGOD*!,PSGOE7*,PSGOE8*,PSGOEF*,PSGOESF*!,PSJCOM,PSJOE1!
   PSGDRG       PSGOD*~,PSGOE41,PSGOE42*,PSGOE7*,PSGOE81,PSGOE82*,PSGOEF*
                PSGOER*~,PSJOE!,PSJOE1
>> PSGDRGN      PSGOE7*,PSJOE1*
   PSGDRGTMP    PSGOE8*!
   PSGDT        PSGNE3*~,PSGOD,PSGOE41,PSGOE81,PSGOEF*,PSGOER*~,PSGOER0*~
                PSGOESF*~,PSGOEV,PSGPEN*,PSJCOM*,PSJOE1
   PSGDW        PSGOER~
>> PSGEB        PSGOEF
>> PSGEBN       PSGOD*,PSJOE1*
   PSGEDTOI     PSGOEF!~,PSJOE1*!~
   PSGEFN       PSGOD*!,PSGOEF!,PSJOE1*!
   PSGEFN(      PSGOD*,PSJOE1*
   PSGEFN(8     PSGOE8
   PSGF2        PSGOE41*!,PSGOE42*!,PSGOE81*,PSGOE82*!,PSGOE92*!,PSGOER0*!
   PSGFD        PSGNE3,PSGOD*,PSGOE41*,PSGOE81*,PSGOEF*,PSGOER!,PSGOER0*
                PSGOESF,PSJCOM,PSJOE1*
>> PSGFDN       PSGOD*,PSGOE81*,PSGOEF*,PSGOER0*,PSJOE1*
   PSGFDNOLD    PSGOE81*!
   PSGFDX       PSGNE3,PSGOE81*!,PSGOEF!,PSJOE~,PSJOE1~
   PSGFLD       PSJCOM~
   PSGFLG       PSGOE41,PSGOE7*~
   PSGFOK       PSGOER!,PSGOER0!,PSGOESF!
   PSGFOK(1     PSGOE42*,PSGOER0*,PSGOESF
   PSGFOK(10    PSGOE41*,PSGOER0*
   PSGFOK(106   PSGOER,PSGOER0*
   PSGFOK(13    PSGOE42
   PSGFOK(25    PSGOE41*,PSGOER0*
   PSGFOK(39    PSGOE41*
   PSGFOK(5     PSGOE42*
   PSGFOK(8     PSGOE41*
   PSGGCNID     PSGOE7*~
   PSGGCNPT     PSGOE7*~
   PSGHSM       PSGOD*!,PSGOE42*,PSGOE82*,PSGOE92*,PSJCOM
   PSGID        PSGPEN!
   PSGIENID     PSGOE7~
>> PSGLI        PSGOE81,PSGOEF,PSGOER0,PSJOE1*
>> PSGLIN       PSGOD*,PSGOEF*,PSJOE1*
   PSGLMT       PSGOESF*,PSJOE*~
   PSGMAR       PSGPEN!
   PSGMR        PSGOD*!,PSGOE8*,PSGOESF*~,PSJOE1!
   PSGMRN       PSGOE8*,PSGOESF*,PSJOE1!
>> PSGND        PSJCOM*
   PSGND1       PSGOE82~
   PSGND3       PSGOE82~
   PSGND4       PSGOER*!
   PSGNDFID     PSGOE7*~
   PSGNE3       PSGNE3!
   PSGNEDFD     PSGNE3,PSGOD*!,PSGOE41,PSGOE7*,PSGOE8*,PSGOEF*,PSGOER0*!
                PSGOESF,PSJOE*!,PSJOE1!
   PSGNEF       PSJOE*!
   PSGNEFD      PSGNE3*,PSGOD*!,PSGOE41*,PSGOE81*,PSGOEF,PSGOER0~,PSJOE!
                PSJOE1!
   PSGNEFDO     PSGNE3*,PSGOE41,PSJOE1~
   PSGNEFDOLD   PSGOE41*,PSGOE81*!
   PSGNEPR      PSJOE!
   PSGNESD      PSGNE3*,PSGOD*!,PSGOE41*,PSGOE81*,PSGOEF*,PSGOER*,PSGOER0*~
                PSJOE!,PSJOE1!
>> PSGNESDO     PSGNE3*,PSGOE41*
   PSGNEW       PSGNE3*!
>> PSGNODE      PSGOT*
   PSGNSTAT     PSGOEF*!
>> PSGOAT       PSGOE8*,PSGOE81*
   PSGOC        PSGOER~
   PSGOD        PSGPEN!
   PSGODA       PSGOEV!,PSGOT*,PSJCOM!
   PSGODDD      PSGOESF*!,PSJOE~
   PSGODDD(     PSGOESF,PSJOE
   PSGODDD(0    PSJOE
   PSGODDD(1    PSGOER0,PSGOESF*,PSGOEV,PSJCOM
   PSGODF       PSGNE3!,PSGOD*!
   PSGODN       PSGOD!
   PSGODN(      PSGOD*
   PSGODN(0     PSGOD
   PSGODN(1     PSGOD*
   PSGODN(2     PSGOD
   PSGODN(3     PSGOD*
   PSGODN(6     PSGOD
   PSGODO       PSGOE7!,PSGOEF
   PSGOE        PSJOE!
>> PSGOE2       PSGOT
>> PSGOE3       PSGOE41
   PSGOEA       PSGNE3,PSGOEF*,PSJOE!
   PSGOEAO      PSGOEF*~
   PSGOEAV      PSGOD,PSGOEF*,PSGOER*~,PSGOEV*,PSJCOM,PSJOE*!,PSJOE1
   PSGOEDMR     PSJOE!
   PSGOEE       PSGOD!,PSGOE8*,PSGOE81*,PSGOE82*,PSGOE92*,PSGOEF*,PSGOER*!
                PSGOESF*,PSJOE1!
   PSGOEEF      PSGOD!,PSGOE82,PSGOE92,PSGOEF*!,PSJOE*,PSJOE1*!
   PSGOEEF(     PSGOE8*,PSGOE81,PSGOE82,PSGOE92,PSGOEF*
   PSGOEEF(109  PSGOE82*,PSGOE92*,PSGOEF*,PSGOEV*,PSJCOM*
   PSGOEEF(26   PSGOEF*
   PSGOEEF(39   PSGOE8*,PSGOEF*
   PSGOEEF(6    PSGOE82*!,PSGOE92*!
   PSGOEEF(7    PSGOE8*
>> PSGOEEG      PSGOEF*,PSJOE1*
   PSGOEEND     PSGOE82!,PSGOE92*!
>> PSGOEENO     PSGOEF*,PSGOER*,PSJOE1*
   PSGOEER      PSGOEF!,PSJOE1
>> PSGOEEWF     PSJCOM*,PSJOE1*
>> PSGOEF       PSGOEF*
   PSGOEF39     PSGOEF*~
>> PSGOEFF      PSGOEF*,PSGOESF*
   PSGOENG      PSJOE*!
>> PSGOEORD     PSGOER*
   PSGOEORF     PSJOE!
   PSGOEOS      PSGOD!,PSGOER!,PSJOE1!
   PSGOEPR      PSGOD*,PSGOER~,PSGOER0*!,PSJOE!
   PSGOER0      PSGOER!,PSGOER0*!
   PSGOER1      PSGOER!
   PSGOER2      PSGOER!,PSGOER0*!
   PSGOERDP     PSGOER!,PSGOER0*!
   PSGOERS      PSGOESF*!
>> PSGOERS1     PSGOESF*
   PSGOERS2     PSGOESF*!
   PSGOES       PSGNE3!,PSGOE8~,PSGOEF*!~,PSGOER~,PSGOEV*~,PSJOE,PSJOE1!
   PSGOFD       PSGOEF*,PSGOER~,PSGOER0*!,PSGOESF*
>> PSGOHSM      PSJCOM
>> PSGOINST     PSGOD*,PSJOE1*
   PSGOL        PSJOE!
   PSGOLD       PSJCOM*~
   PSGOLDED     PSGOE41*,PSGOE81*!
   PSGON        PSJOE!
>> PSGONC       PSJOE*
   PSGONF       PSGOEF!,PSGOER0,PSGOESF*~,PSGOEV,PSJCOM
   PSGONF2      PSGOESF*~
>> PSGOOPD      PSGOE8*
>> PSGOOPDN     PSGOE8*
   PSGOORD      PSGOER*~
   PSGOP        PSGOD,PSJOE*!
   PSGOPR       PSGOEF,PSGOER,PSGOER0*!
   PSGORD       PSGNE3,PSGOD*,PSGOE41,PSGOE7!,PSGOE8,PSGOE81,PSGOE82,PSGOE92
                PSGOEF,PSGOEF,PSGOER*~,PSGOER~,PSGOER0~,PSGOESF*!,PSGOEV*~
                PSGOEV~,PSGOT*,PSJCOM,PSJOE*!~,PSJOE1!
   PSGORDP      PSGOEV*~,PSJCOM*
   PSGORDR      PSGOEV*~
   PSGOREAS     PSGOER~
   PSGOROE1     PSGOE41*,PSGOE42*,PSGOER0!,PSJOE1!
   PSGORQF      PSGOD!,PSGOE7*,PSGOE82~,PSGOEF,PSGOER*!,PSGOER0,PSGOESF!
                PSGOEV~,PSJOE1*!~
   PSGOS        PSJOE!
>> PSGOSCH      PSGOEF*
   PSGOSD       PSGOER0*!,PSGOESF*
>> PSGOST       PSGOE8*
   PSGP         PSGNE3,PSGOD,PSGOE41*~,PSGOE7,PSGOE81*~,PSGOE82,PSGOE92,PSGOEF
                PSGOER~,PSGOER,PSGOER0~,PSGOESF,PSGOEV,PSGOT,PSGOT,PSGPEN
                PSJCOM,PSJOE*~,PSJOE~,PSJOE1
   PSGPD        PSGOE8*,PSGOEF*,PSGOEV*!,PSJCOM*,PSJOE*,PSJOE1*
>> PSGPDN       PSGOD*,PSGOE8*,PSGOEF*,PSGOT,PSJCOM,PSJOE*,PSJOE1*
   PSGPDNOLD    PSGOE8*!
>> PSGPDNX      PSGNE3,PSGOE8*
   PSGPDOLD     PSGOE8*!
   PSGPDRG      PSGNE3,PSGOD*!~,PSGOE42,PSGOE7*,PSGOE8*,PSGOE82,PSGOEF*
                PSGOER0*!,PSJOE1
   PSGPDRGN     PSGOE7*,PSGOE8*,PSGOEF*,PSGOESF*!
   PSGPDRGOLD   PSGOE8*!
>> PSGPEN       PSGPEN*
   PSGPENO      PSGPEN*~
>> PSGPENWS     PSGPEN*
   PSGPFLG      PSGOEV*!
   PSGPLC       PSGPEN!
   PSGPLF       PSGPEN*!
   PSGPLO       PSGPEN*!
   PSGPLS       PSGPEN*!
   PSGPLUD      PSGPEN!
   PSGPOI       PSGOER*~
   PSGPOSA      PSGOER*!
   PSGPOSD      PSGOER*!
   PSGPR        PSGOD*!,PSGOE42*,PSGOE82*,PSGOE92*,PSGOER*!~,PSGOER0*,PSJCLOZ
>> PSGPRF       PSJOE
   PSGPRI       PSGOER0*!,PSJOE!
>> PSGPRIO      PSGPEN
   PSGPRN       PSGOE42*,PSGOE82*,PSGOE92*,PSGOER0*!
>> PSGPTMP      PSJOE*
   PSGPTS       PSJOE!
   PSGPX        PSGOER!
>> PSGPXN       PSGOESF,PSGPEN*,PSJOE*
   PSGPXPT      PSJOE*!
   PSGRD        PSGOER!
   PSGRDTX      PSGNE3,PSGOEF!,PSGOEV*,PSJCOM,PSJOE!~
   PSGRDTX(     PSGOEF
>> PSGRENEW     PSGOER0
   PSGRFD       PSGOEV!,PSJCOM*!,PSJOE~
   PSGRFDN      PSJOE~
   PSGRFOUR     PSGOER*~
   PSGRLAST     PSGOESF*!
   PSGRNSD      PSGOEF*~,PSGOER0*!
   PSGRO        PSGOER0*!
>> PSGRRF       PSJOE
   PSGRSD       PSGOEF!,PSGOEV!,PSJCOM*!,PSJOE~
   PSGRSDN      PSGOEF!,PSJOE~
   PSGRZERO     PSGOER*~
   PSGS0XT      PSGNE3,PSGOD*!,PSGOE41,PSGOE81,PSGOEF,PSGOER*~,PSGOER0*!
                PSGOEV*~,PSGOT,PSJCOM,PSJOE!,PSJOE1!
   PSGS0Y       PSGNE3,PSGOD*!,PSGOE41*,PSGOE8,PSGOE81*,PSGOEF~,PSGOER~
                PSGOER0*!,PSGOEV~,PSJOE!,PSJOE1!
   PSGSCH       PSGNE3,PSGOD*!,PSGOE41,PSGOE8*,PSGOE81,PSGOEF~,PSGOER,PSGOER0*!
                PSGOESF*!,PSGOEV,PSJCOM,PSJOE,PSJOE1!
   PSGSD        PSGOD*,PSGOE41*,PSGOE81*,PSGOEF*,PSGOER!,PSGOER0*~,PSGOESF
                PSJCOM,PSJOE1*
   PSGSDN       PSGOD*,PSGOE81*,PSGOEF*,PSGOER0*!,PSJOE!,PSJOE1*
   PSGSDX       PSGNE3,PSGOE81*!,PSJOE~,PSJOE1~
   PSGSFD       PSGOESF*~
   PSGSFLG      PSGOE8*~
   PSGSI        PSGOD*,PSGOE41*,PSGOE81*,PSGOEF*,PSGOESF*!,PSJCOM,PSJOE1!
   PSGSM        PSGOD*!,PSGOE42*,PSGOE82*,PSGOE92*,PSJCOM
   PSGST        PSGNE3*,PSGOD*!,PSGOE41,PSGOE8*,PSGOE81,PSGOEF,PSGOER~
                PSGOER0*!,PSGOESF*,PSGOEV,PSJCOM*,PSJOE1
>> PSGSTAT      PSGOD*,PSGOEF*,PSJOE,PSJOE1*
>> PSGSTN       PSGOE8*
>> PSGTDD       PSJOE1*
   PSGTMPXN     PSJOE*~
   PSGTOL       PSGOD!,PSGOER!,PSGOEV*!,PSGOT*,PSJOE!
   PSGTOO       PSGOD!,PSGOER!,PSGOEV*!,PSGOT*,PSJOE!
>> PSGUD        PSGOE42
   PSGUDFIN     PSGOEF*~
   PSGUOW       PSGOD!,PSGOER!,PSGOEV*!,PSGOT*,PSJOE!
   PSGUSRX      PSGOE7*!
   PSGVBY       PSJOE!
   PSGWALLO     PSGOEF*~
   PSGWLL       PSGOER*!,PSGOER0*!,PSGOESF*
   PSGX         PSGOE7*,PSGOE82*~,PSGOE92*~,PSGOEV*~,PSJCOM*~,PSJOE1!
   PSGXDA       PSGOEV*~
   PSGXX        PSGOE82*~,PSGOE92*!~
   PSGY         PSGOE82*~,PSGPEN*
   PSIVAC       |opt!
   PSIVAT       PSJOE!
>> PSIVCOPY     PSJOE
   PSIVENO      PSJOE!~
   PSIVFLG      PSJOE*!
   PSIVLN       PSJOE!
   PSIVREA      PSJOE!
   PSIVSTR      PSJOE!
   PSIVUP       |opt!
   PSJ          PSJRXLAB*~
>> PSJ1PH       PSJCLOZ*
   PSJ2         PSJRXLAB*~
>> PSJ2PH       PSJCLOZ*
   PSJABT       PSGOER~
   PSJACEPT     PSGOD*!,PSGOEF*!,PSGOEV*,PSJCOM*,PSJOE1*!
   PSJACNWP     PSJOE~
   PSJACOK      PSJOE*!
   PSJACPF      PSJOE*~
   PSJAGYSV     PSGOEF*,PSGOEV!,PSJOE*!~
   PSJALGY1     PSGOE82,PSJOE1*~
   PSJALLGY     PSGOD~,PSGOE7!~,PSGOE82~,PSGOER~,PSGOESF~,PSGOEV~,PSJOE1~
   PSJALLGY(    PSGOD*,PSGOE7*,PSGOE82*,PSGOER*,PSGOESF*,PSGOEV*
   PSJALLGY(0   PSGOD,PSGOER,PSGOESF
   PSJANS       PSJRXLAB*!
   PSJAPR       PSJCLOLS*!
   PSJBD        PSJRXLAB*!
   PSJBDR       PSJRXLAB*!
   PSJBINTR     PSJRXLAB~
   PSJBLGTH     PSJRXLAB~
>> PSJBLOOP     PSGOD
>> PSJCLPAT     PSJCLOZ*
   PSJCNT       PSGOEV*~
   PSJCNT1      PSGOEV*~
   PSJCNT2      PSGOEV*~
>> PSJCOFLG     PSGOD
>> PSJCOI       PSGOEF,PSJOE
   PSJCOM       PSGOEF*~,PSGOER,PSGOEV*,PSJCLOLS*!,PSJCOM,PSJOE
   PSJCT        PSJOE!
   PSJCT1       PSGOEF*!
   PSJCT1A      PSGOEF*!
   PSJDAOC      PSGOEF*~
   PSJDATA      PSJCLOLS*!
   PSJDD        PSGOD*~,PSGOE82*~,PSGOEF*~,PSGOER*~,PSGOESF*~,PSGOEV*~,PSJOE1*~
   PSJDD0       PSGOER*~
   PSJDD55      PSGOE92*!
   PSJDD55(     PSGOE92*
   PSJDD551     PSGOE92*!
   PSJDDI       PSGOE82~,PSGOER~,PSGOESF~
   PSJDDTMP     PSGOE92*!
   PSJDDTMP(    PSGOE92*
>> PSJDGCK      PSGOE7
   PSJDGN       PSJRXLAB*!
   PSJDIS       PSGOEV*~
   PSJDOSE      PSGOE7!,PSGOE82~,PSGOE92~,PSGOEF*~,PSGOEV!~,PSJCOM!~
   PSJDOSE("WARN" 
                PSGOEV,PSJCOM
   PSJDOSE("WARN1" 
                PSGOEV,PSJCOM
   PSJDOX       PSGOE7!,PSGOEF~
   PSJDOX(      PSGOEF
   PSJDOX(1     PSGOEF
   PSJDRG       PSJCLOLS*!
   PSJDRUG      PSJRXLAB*!
   PSJDRUGN     PSJRXLAB*!
   PSJDSFLG     PSGOE82,PSGOE92,PSGOEF~,PSGOEV~,PSJCOM~
   PSJDSVFY     PSGOEV,PSJOE~
   PSJDTMP1     PSGOE92*!
   PSJED        PSJRXLAB*!
   PSJEDITO     PSJOE*~
   PSJEDR       PSJRXLAB*!
   PSJENHOC     PSJOE~
   PSJEXCPT     PSJOE!
   PSJEXPIR     PSGOER*~
   PSJEXPOE     PSGOER*!
   PSJFILE      PSJRXLAB~
   PSJFLG       PSGOEV*~
>> PSJHLDFN     PSGOEV
   PSJINACT     PSGOE8*~
   PSJINDIC     PSJRXLAB*!
   PSJINTR      PSJRXLAB~
   PSJIREQ      PSGOE82*~,PSGOER*~,PSGOESF*~
   PSJIVFLG     PSJOE*~
   PSJIVOF      PSJOE!
   PSJIVORF     PSJOE!
   PSJIVPCL     PSJOE!
   PSJJDRUG     PSGOESF*!
   PSJLABQ      PSJRXLAB*!
   PSJLABT      PSJRXLAB*!
   PSJLABTN     PSJRXLAB*!
   PSJLBENT     PSJRXLAB*!
   PSJLBT       PSJRXLAB*!
   PSJLDATE     PSJRXLAB*!
   PSJLENTH     PSJRXLAB~
   PSJLK        PSJOE*~
   PSJLM        PSJOE*!~
   PSJLMCON     PSJOE*~
   PSJLMFIN     PSGOEF*,PSGOEV,PSJOE~
>> PSJLMP2      PSGOEF*
   PSJLMPRO     PSJOE*!
   PSJLMQT      PSJOE~
   PSJLUAPP     PSGOE7!
   PSJLYN       PSJOE*!
   PSJMAI       PSJOE!
   PSJNEWOE     PSGOE8,PSGOEV,PSJOE*~,PSJOE1
   PSJNODIS     |opt*!
   PSJNOL       PSJOE!
   PSJNOO       PSGOD*,PSGOEF*,PSGOER*~,PSGOER0*!,PSJOE1*
   PSJNORD      PSJOE1*~
   PSJNSS       PSGOD!,PSGOEF!,PSGOER~
   PSJNUM       PSJCLOLS*,PSJRXLAB*~
   PSJOCDS      PSGOESF~
   PSJOCDSC     PSJOE!~
   PSJOCDSC("CX" 
                PSGOEF*
   PSJOCER      PSJOE!
   PSJOCFG      PSGOD,PSGOER0,PSJOE*!~,PSJOE1*!~
   PSJOCNT      PSGOE7,PSGOESF,PSJOE!
   PSJOD        PSJCLOLS*!
   PSJOE        PSJOE!
   PSJOECNT     PSJOE!
   PSJOEPF      PSJOE!
>> PSJOL        PSJOE*
   PSJON        PSJOE!
   PSJOPC       PSJOE!
   PSJORD       PSGNE3,PSGOD*,PSGOE7!,PSGOE92,PSGOER,PSGOEV,PSGPEN,PSJCLOLS*
                PSJOE*!~,PSJOE*~,PSJOE1*
   PSJORDER     PSGOER*~
   PSJORDER("PSJORN" 
                PSJCLOZ*
   PSJORDN      PSJRXLAB*!
   PSJORIFN     |opt!
   PSJORL       PSJOE!
>> PSJORN       PSJCLOZ*
   PSJORPCL     PSJOE!
   PSJORQF      PSGOE7*,PSJOE!,PSJOE1*
   PSJORTOI     PSJOE!
   PSJORTOU     PSJOE!
   PSJORVP      PSJOE!
   PSJOVR       PSGOEF!
   PSJOVR("CONJ" 
                PSGOEF
   PSJOVRLP     PSGOEF!
   PSJOVRMX     PSGOT*~
>> PSJOWALL     PSJCOM*
   PSJPAT       PSJCLOLS*!
>> PSJPDD       PSJOE
   PSJPDRG      PSGOE82~,PSGOER~,PSGOESF~
   PSJPDXP      PSJOE*!
   PSJPIECE     PSGOEF*~
   PSJPNDRN     PSGOE82*~
   PSJPNV       PSJOE~
   PSJPR        PSJOE!
>> PSJPRI       PSGOEV,PSJCOM
   PSJPRIO      PSGOEV*~
   PSJPRN       PSGPEN*~
   PSJPROT      PSGOEF,PSJOE*~,PSJRXLAB*!
   PSJPROV      PSJCLOZ*,PSJRXLAB*!
   PSJPROVN     PSJRXLAB*!
   PSJPSTO      PSGOER~
   PSJPT        PSJRXLAB*!
   PSJPWD       PSGOER~,PSGOT,PSGPEN,PSJOE*~
   PSJPXDP      PSJOE~
   PSJQUIT      PSJCLOZ*~
   PSJRBCNT     PSGOE8*~
   PSJREA       PSJCLOLS*!
>> PSJREASN     PSJCLOZ*
>> PSJREMRK     PSJCLOZ*
   PSJREN       PSGNE3,PSGOER*~,PSGOER0*!,PSGPEN
>> PSJRNF       PSGOEF,PSJCOM
   PSJRNOS      PSGPEN*~
   PSJRSB       PSGOE8*~
   PSJRX        PSJCLOLS!
   PSJRXREQ     PSGOE82*~,PSGOER*~,PSGOESF*~
   PSJSCHED     PSGOEV*~
>> PSJSEL       PSJOE*
>> PSJSEL1      PSJOE*
   PSJSITE      PSGPEN*~
   PSJSLUP      PSGOE8*~
   PSJSP        PSJRXLAB*!
   PSJSPEED     PSGOER,PSGOER0,PSGOESF*!,PSGOEV,PSJCOM
   PSJSTARI     PSGOEV,PSJOE!
   PSJSYSL      PSGOEV,PSJOE~
>> PSJSYSO      PSGOER
   PSJSYSP      PSGOD,PSGOE41,PSGOE42,PSGOE7,PSGOE8~,PSGOE81,PSGOE82,PSGOE92
                PSGOEF,PSGOER,PSGOER0,PSGOESF,PSGOEV,PSJCOM,PSJOE
>> PSJSYSP0     PSGOEF,PSGOER,PSGOER0,PSGOESF,PSGOEV,PSJOE,PSJOE1
>> PSJSYSU      PSGOD,PSGOE42,PSGOE7,PSGOE8,PSGOE82,PSGOE92,PSGOER,PSGOER0
                PSGOEV,PSJCOM,PSJOE,PSJOE1
   PSJSYSW      PSJOE~
   PSJSYSW0     PSGNE3*,PSGOE41,PSGOE42,PSGOE8,PSGOER,PSGOER0,PSGOESF,PSGPEN*
                PSJOE*~
   PSJTMPLIN    PSGOT~
   PSJTMPTX     PSGOT*~
>> PSJTUD       PSGOEF,PSJOE
   PSJTYPE      PSJRXLAB*!
   PSJUDPRF     PSJOE~
   PSJUNIT      PSGOEF*~,PSJRXLAB*!
   PSJUSR       PSJCLOLS*!
   PSJVAR       PSGOEV!,PSJCOM!
   PSJX         PSGOEF*~,PSGOER*~,PSGOESF*~,PSGOEV*~
>> PSJXDOX("DD" PSGPEN
   PSJXX1       PSJOE*~
   PSJY         PSGOER~
   PSJYSCL      PSJOE*~,PSJOE1!
   PSOBD        PSJCLOLS*!
   PSOED        PSJCLOLS*!
   PSOI         PSJCLOLS*!
>> PSOLAST4     PSJCLOZ*
>> PSOYS        PSJCLOZ
   PSREV        PSJRXLAB*!
   PSTMPI       PSGOE42*!,PSGOE82*!,PSGOE92*!,PSGOER0*!
   PSTMPN       PSGOE42*!,PSGOE82*!,PSGOE92*!,PSGOER0*!
   Q            PSGOD*~,PSGOE7*~,PSGOEF*,PSGOER*,PSGOESF*,PSGOEV*~,PSGOT*
                PSGPEN*,PSJCOM*!
   Q1           PSGOE7*!,PSGOEF!,PSGPEN*
   Q2           PSGOE7!,PSGOEF!,PSGPEN*
   Q3           PSGOE7*!
>> QOAA         PSJCLOZ
   QODS         PSJCLOZ*~
>> QOIEN        PSJCLOZ
   QORF         PSJCLOZ*~
   QQ           PSGOEV*~,PSGPEN*,PSJCOM*!
   QX           PSGOD~,PSGOER~,PSGOEV~
   RCT          PSJOE!
   RDATE        PSGOER~
   RDUZ         PSGOER~
   RET          PSGOEF~
   RF           PSGOER!,PSJOE!
   RNDT         PSGPEN*~
   RNWDT        PSGOER~
>> RNWL         PSGOE8*
   RTN          PSGOE7*~,PSJCLOZ*~
   SCH          PSGNE3~,PSGOE8~
   SCHED        PSGOER*~
   SD           PSGNE3~,PSGOER~
   SDT          PSGOE41!,PSGOE42!,PSGOE82!,PSGOE92!,PSGOER0!
   SDW          PSGOD~,PSGOER~,PSGOEV~
   SIARRAY      PSJCOM*~
   SIMSG        PSGOT*~
   SITE         PSJRXLAB*!
   ST           PSGOER~,PSGOESF*~,PSJOE!
   STATUS       PSGOER*~
   STOP         PSGOER*~
   SWD          PSGOD~,PSGOER~,PSGOEV~
   TEST         PSGOER~
>> TIUDA        PSGOEV,PSJCOM
   TMPFD        PSGOE81*!~
>> TMPLIN       PSGOT*
   TMPX         PSGOE41*~,PSGOE81*~
   TT           PSGNE3!
>> TXT          PSGOT*
   TXTLN        PSGOEV*~
   U            PSGNE3,PSGOD,PSGOE41,PSGOE7,PSGOE8,PSGOE81,PSGOEF,PSGOEF
                PSGOER*~,PSGOER0,PSGOESF,PSGOEV,PSGOT,PSGPEN,PSJCLOZ,PSJCOM
                PSJOE,PSJOE1
>> UD           PSGPEN*
   UL80         |opt!
>> VA("PID"     PSJRXLAB
   VAERR        PSJOE~
   VAIN         PSJOE~
   VAIN(4       PSGOD,PSJOE
   VAIP         PSJOE~
>> VALM("TM"    PSJOE,PSJOE1
   VALMBCK      PSGOD*,PSGOEF*,PSGOER*~,PSGOESF*,PSGOEV*,PSJCOM*,PSJOE*,PSJOE1*
>> VALMBG       PSGOEF*
   VALMEVL      PSJOE~
>> VALMQUIT     PSJOE*
   VALMSG       PSGOEF*,PSJOE1*!
   VND4         PSGOEV*!,PSJCOM*!
   WALL         PSGNE3*~
   WD           PSGOER~,PSJOE!
   WG           PSGPEN*!
   WSCHADM      PSJOE!
   X            PSGNE3*~,PSGOD*!~,PSGOE41*!~,PSGOE41~,PSGOE42*,PSGOE7*~,PSGOE8*
                PSGOE8*~,PSGOE81*!~,PSGOE81~,PSGOE82*,PSGOE92*~,PSGOEF*~
                PSGOEF*,PSGOER*~,PSGOER0*!,PSGOESF*!,PSGOEV*!~,PSGOT*
                PSJCLOLS*!,PSJCLOZ*!,PSJCOM*!~,PSJOE*,PSJOE1*,|dd53.8*!
                |dd55.06!
   X(1          PSGOT*
   X(2          PSGOT*
   X1           PSGNE3*~,PSGOE41*~,PSGOE81*~,PSGOEF*~,PSGOESF*
   X2           PSGNE3*~,PSGOE41*~,PSGOE81*~
   X3           PSGNE3*~,PSGOE41*~
   X3DMIN       PSGNE3*~
   XABB         PSGOD~,PSGOER~,PSGOEV~
>> XD           PSGNE3*
>> XMY          PSJCLOZ
   XP           PSGOER*~
>> XQA          PSJCLOZ*
>> XQA(         PSJCLOZ*
>> XQAARCH      PSJCLOZ*
>> XQADATA      PSJCLOZ*
>> XQAFLG       PSJCLOZ*
>> XQAID        PSJCLOZ*
>> XQAMSG       PSJCLOZ*
>> XQORNOD(0    PSJOE
   XQORS        PSJOE~
   XQUIT        PSJOE!
   XREF         PSJOE!
   XX           PSGOE8*~,PSGOER0*~,PSGOT!
   Y            PSGNE3*~,PSGOD!,PSGOE41*!,PSGOE42*,PSGOE7*,PSGOE8,PSGOE81*
                PSGOE82*,PSGOE92*~,PSGOEF*,PSGOER*~,PSGOER0*!,PSGOESF*!
                PSGOEV*!~,PSGPEN,PSJCLOLS,PSJCLOZ*!~,PSJCOM~,PSJOE,PSJOE1!
                PSJRXLAB*!,|dd53.8
   Y(0          PSGOE42,PSGOE7*,PSGOE8,PSGOE82,PSGOE92,PSGOER0
   YP           PSGOER*~
>> YSCLR        PSJOE
   Z            PSGOE41*~,PSGOE7*!,PSGOE81*~,PSGOEF~,PSJOE!,PSJOE1!
   ZND          PSGOT*!
   ZTDESC       PSJCLOLS*!,PSJRXLAB*!
   ZTIO         PSJCLOLS!
>> ZTQUEUED     PSJRXLAB
>> ZTREQ        PSJRXLAB*
   ZTRTN        PSJCLOLS*!,PSJRXLAB*!
   ZTSAVE       PSJCLOLS!,PSJRXLAB!
   ZTSAVE("*"   PSJRXLAB*
   ZTSAVE("PSOBD" 
                PSJCLOLS*
   ZTSAVE("PSOED" 
                PSJCLOLS*
   ZTSK         PSJCLOLS!,PSJRXLAB!
   ZZND         PSGOEF!,PSGOER~,PSGOEV!,PSGOT

Global Variables
   ^DD("DD"            PSJCLOZ,PSJRXLAB
   ^DPT(               PSJCLOLS,PSJCLOZ,PSJOE,PSJRXLAB
   ^LAB(60             PSJRXLAB
   ^LR(                PSJRXLAB
   ^OR(100             PSJCLOLS,PSJRXLAB
   ^ORD(101            PSGOEV
   ^ORD(101.41         PSJCLOZ
   ^PS(50.3            PSGOE7
   ^PS(50.7            PSGOE7,PSGOE8,PSGOEV
   ^PS(51.1            PSGNE3,PSGOE41,PSGOE8,PSGOE81,PSGOER
   ^PS(51.2            PSGOE8
   ^PS(52.41           PSJRXLAB
   ^PS(52.54           PSJCLOLS
   ^PS(53              PSJCLOZ
   ^PS(53.1            PSGNE3*,PSGOD,PSGOE82,PSGOE92,PSGOEF*,PSGOESF*,PSGOEV
                       PSGOT*,PSJCOM,PSJOE,PSJOE1
   ^PS(53.4            PSGPEN*
   ^PS(53.41           PSGOT
   ^PS(53.44           PSGOT
   ^PS(53.45           PSGOD*!,PSGOE41,PSGOE42,PSGOE7!,PSGOE8*!,PSGOE81
                       PSGOE82!,PSGOE92,PSGOEF*!,PSGOER*!,PSGOER0!,PSGOESF*!
                       PSGOEV*!,PSJCOM,PSJOE
   ^PS(53.46           PSGNE3
   ^PS(53.5            PSGPEN
   ^PS(53.8            PSJCLOLS,|dd53.8*!
   ^PS(55              PSGNE3*,PSGOD,PSGOE92,PSGOEF*,PSGOER*,PSGOER0,PSGOESF
                       PSGOEV*!,PSGOT*,PSGOT!,PSGPEN,PSJCOM,PSJOE,PSJOE1*
   ^PS(57.5            PSGPEN
   ^PS(59.7            PSGOE7,PSGOER,PSGPEN
   ^PSD(58.8           PSGPEN
   ^PSDRUG(            PSGOE7,PSGOE92,PSGOEF,PSGOER,PSGOESF,PSGOEV,PSGPEN
                       PSJCLOLS,PSJCLOZ,PSJRXLAB
   ^PSDRUG("ACLOZ"     PSGOD,PSGOE42,PSGOE8,PSGOE82,PSGOEF,PSGOER,PSJOE,PSJOE1
   ^PSDRUG("ASP"       PSGOE42,PSGOE7,PSGOE8,PSGOE82,PSGOEF
   ^PSDRUG("B"         PSJRXLAB
   ^PSI(58.1           PSGPEN
   ^TMP("CLOZFLG"      PSGOE41,PSGOE81
   ^TMP("ORDERNUM"     PSJRXLAB*!
   ^TMP("PSJ"          PSGOESF,PSJOE!
   ^TMP("PSJATOVR"     PSGOEF!
   ^TMP("PSJCOM"       PSGOT,PSJCOM*,PSJOE!
   ^TMP("PSJCOM2"      PSJCOM*,PSJOE!
   ^TMP("PSJDAOC"      PSGOER!,PSJOE!
   ^TMP("PSJINTER"     PSGOE7!
   ^TMP("PSJON"        PSGOESF,PSGOT,PSJOE!
   ^TMP("PSJPRO"       PSJOE!
   ^TMP("PSODAOC"      PSGOE7!,PSGOEF!,PSGOER*!,PSGOEV*,PSJCOM*,PSJOE*!,PSJOE1*
   ^TMP($J             PSGOEV!,PSJOE!
   ^UTILITY("DIQ1"     PSJRXLAB!
   ^VA(200             PSGOE42,PSGOE82,PSGOE92,PSGOER0,PSJCLOLS,PSJRXLAB
   ^XUSEC("PSOLOCKCLOZ"PSJCLOZ
   ^XUSEC("YSCL AUTHORIZED"
                       PSJCLOZ

Naked Globals
   ^(           PSGOD,PSGOE42,PSGOE7,PSGOE8,PSGOE82,PSGOEF,PSGOER,PSGOER0
                PSGOESF,PSGOEV,PSGOT*!,PSGPEN,PSJCLOLS,PSJCOM,PSJRXLAB
   ^("B"        PSGOT
   ^("DSS"      PSGOT
   ^("I"        PSGOE7,PSGOER,PSGOESF,PSGOEV
   ^("PS"       PSGOE42,PSGOE82,PSGOE92,PSGOER0
   ^("SIG"      PSJRXLAB
   ^(0          PSGOD,PSGOE8,PSGOEV*,PSGOT*,PSGPEN*,PSJCLOLS,PSJCOM*,PSJRXLAB
   ^(1          PSGOE42*,PSGOE8*
   ^(2          PSGOE42*,PSGOE7,PSGOER!,PSGOER0!,PSGOESF*,PSGOEV,PSJCOM*
   ^(4          PSGOEV,PSJOE
   ^(5.1        PSGOT*
   ^(6          PSGOESF
   ^(7          PSGOEV*
   ^(8          PSGOT

Cache Objects
   NONE

Marked Items
   $T(32        PSGOEF
   $T(38        PSGOEF
   $T(39        PSGOEF
   $T(@(3)      PSGOE82,PSGOE92,PSGOEF

Routine             Invokes:
   PSGNE3       C^%DTC,DW^%DTC,H^%DTC,NOW^%DTC,YMD^%DTC,EN^DIK,$$EN^PSBAPIPM
                EN1^PSGDL,$$ENDD^PSGMI,$$ENOSD^PSJDCU,$$DURMIN^PSJLIVMD
                $$GETDUR^PSJLIVMD,$$ENQ^PSJORP2,$$DATE^PSJUTL2,$$DATE2^PSJUTL2
                $$FMADD^XLFDT,$$FMDIFF^XLFDT
   PSGOD        YN^DICN,DIR,$$ENDD^PSGMI,$$ENDTC^PSGMI,$$ENNPN^PSGMI,PSGNE3
                PSGOE1,$$GTNEDFD^PSGOE7,ENSFE^PSGOEE0,PSGOETO,CHK^PSGOEV
                EN^PSGPEN,ENOS^PSGS0,ENDDC^PSGSICHK,CLOZ^PSJCLOZ,GETUD^PSJLMGUD
                INIT^PSJLMUDE,$$OINAME^PSJLMUTL,SETOC^PSJNEWOC,IN^PSJOCDS
                $$ENNOO^PSJUTL5,INP^VADPT,EN^VALM,FULL^VALM1,PAUSE^VALM1
   PSGOE41      %DT,%DTC,C^%DTC,YN^DICN,$$ENDL^PSGDL,EN1^PSGDL,ENPREV^PSGDL
                $$ENDD^PSGMI,PSGNE3,ENFD^PSGNE3,1^PSGOE42,ENFF^PSGOEM
                ENHLP^PSGOEM,$$ODD^PSGS0,ENCHK^PSGS0,$$EDITSI^PSJBCMA5
                $$ENOSD^PSJDCU,$$ENQ^PSJORP2,$$ENBCMA^PSJUTL,EFDNEW^PSJUTL
   PSGOE42      DIC,YN^DICN,DIE,ENFF^PSGOEM,ENHLP^PSGOEM,PROVCHK^PSJCLOZ
   PSGOE7       @(,DIC,MIX^DIC1,YN^DICN,DIR,$$ENDDN^PSGMI,ENDDC^PSGSICHK
                KILL^PSJBCMA5,$$DGCKIEN^PSJDGCK,$$PSJSUPCK^PSJDGCK,DIN^PSJDIN
                $$OINAME^PSJLMUTL,READ^PSJUTL,$$PROD0^PSNAPIS
   PSGOE8       DIC,MIX^DIC1,YN^DICN,$$ENLU^PSGMI,$$ENSTN^PSGMI
                $$GTNEDFD^PSGOE7,ENFF^PSGOE82,ENDRG^PSGOEF1,ENHLP^PSGOEM
                $$PRNOK^PSGS0,EN^PSGS0,$$DOW^PSIVUTL,CLOZ^PSJCLOZ
                EDITDOSE^PSJDOSE,$$OINAME^PSJLMUTL,PAUSE^VALM1
   PSGOE81      %DT,%DTC,C^%DTC,EN^DDIOL,YN^DICN,$$ENDL^PSGDL,ENE^PSGDL
                ENPREV^PSGDL,$$ENDD^PSGMI,$$ENDTC^PSGMI,ENFF^PSGOE82
                ENFF^PSGOEM,ENHLP^PSGOEM,$$ODD^PSGS0,$$PRNOK^PSGS0,ENCHK^PSGS0
                $$DIFFSI^PSJBCMA5,$$EDITSI^PSJBCMA5,$$DURMIN^PSJLIVMD
                $$GETDUR^PSJLIVMD
                $$LASTREN^PSJLMPRI,$$ENQ^PSJORP2,$$ENBCMA^PSJUTL,EFDNV^PSJUTL
                PAUSE^VALM1,$$FMADD^XLFDT
   PSGOE82      DIC,YN^DICN,DIE,ENHLP^PSGOEM,$$CODES2^PSIVUTL,PROVCHK^PSJCLOZ
                DOSECHK^PSJDOSE,DSPWARN^PSJDOSE,$$LASTREN^PSJLMPRI
                ALLERGY^PSJOC,PAUSE^VALM1
   PSGOE92      DIC,YN^DICN,DIE,NEWUDAL^PSGAL5,CLOZPRV^PSGOE82,DDOC^PSGOE82
                ENHLP^PSGOEM,$$CODES2^PSIVUTL,CMPLX^PSJCOM1,DOSECHK^PSJDOSE
                DSPWARN^PSJDOSE,$$COMPLEX^PSJOE,FULL^VALM1,PAUSE^VALM1
   PSGOEF       NOW^%DTC,ENDR^%ZISS,DIR,$$ENDD^PSGMI,$$ENDTC^PSGMI
                $$ENSD^PSGNE3,ENFD^PSGNE3,GTST^PSGOE6,$$GTNEDFD^PSGOE7
                ABORT^PSGOEE,DONE1^PSGOEE,NEW3^PSGOEE,ENSFE^PSGOEE0,PSGOEF
                $$ENIVUD^PSGOEF1,ENDRG^PSGOEF1,UPD^PSGOEF1,OVERLAP^PSGOEF2
                OC531^PSGOESF
                EN^PSGORS0,$$ODD^PSGS0,$$PRNOK^PSGS0,ENOS^PSGS0,NSSCONT^PSGS0
                CLOZ^PSJCLOZ,$$DSTART^PSJDCU,DOSECHK^PSJDOSE,$$DURMIN^PSJLIVMD
                $$GETDUR^PSJLIVMD,REQDT^PSJLIVMD,GETUD^PSJLMGUD
                $$LASTREN^PSJLMPRI,INIT^PSJLMUDE,$$OINAME^PSJLMUTL
                $$DD53P45^PSJMISC
                IN^PSJOCDS,OC^PSJOE1,$$ENPC^PSJUTL,$$ENNOO^PSJUTL5,DOSE^PSSORPH
                EN^VALM,REFRESH^VALM,FULL^VALM1,RE^VALM4,$$FMADD^XLFDT
                $$NOW^XLFDT
   PSGOER       NOW^%DTC,FILE^DICN,DIE,DIR,$$EN^PSBAPIPM,PSGAL5,ABORT^PSGOEE
                DATE^PSGOER0,EN^PSGPEN,$$PRNOK^PSGS0,DW^PSGS0,ENDDC^PSGSICHK
                ENPOS^PSGVDS,$$DOW^PSIVUTL,CLOZ^PSJCLOZ,PSJCOMR,EN1^PSJHL2
                $$SCHREQ^PSJLIVFD,PAUSE^PSJLMUT1,SETOC^PSJNEWOC,IN^PSJOCDS
                ENUDTX^PSJOREN,$$ENQ^PSJORP2,$$LASTAT^PSJORP2,ADMIN^PSJORPOE
                $$ACTIVE^PSJORREN,$$DATE^PSJUTL2,$$DATE2^PSJUTL2,$$LS^PSSLOCK
                UNL^PSSLOCK,PAUSE^VALM1,$$FMADD^XLFDT
   PSGOER0      %DT,DIC,$$ENDL^PSGDL,ENGO^PSGDL,$$ENDD^PSGMI,$$ENSD^PSGNE3
                ENFD^PSGNE3,ENWALL^PSGNE3,$$DDOK^PSGOE2,$$GTNEDFD^PSGOE7
                CLOZPRV^PSGOE82,ENDRG^PSGOEF1,ENHLP^PSGOEM,NEWOC55^PSGOER
                $$ENOSD^PSJDCU,$$DURMIN^PSJLIVMD,$$GETDUR^PSJLIVMD
                $$ACTIVE^PSJORREN
                EFDNEW^PSJUTL,$$DATE2^PSJUTL2,$$ENNOO^PSJUTL5,$$FMADD^XLFDT
                $$NOW^XLFDT
   PSGOESF      NOW^%DTC,DIE,DIR,$$ENMRN^PSGMI,$$ENPDN^PSGMI,ENWALL^PSGNE3
                DATE^PSGOER0,HMSG^PSGOERS,EN^PSGOEV,SET^PSGON,PSGPER1
                ENDDC^PSGSICHK,$$DRUGNAME^PSJLMUTL,$$HIDDEN^PSJLMUTL
                $$DD53P45^PSJMISC,IN^PSJOCDS,$$LS^PSSLOCK,UNL^PSSLOCK
                FULL^VALM1
                PAUSE^VALM1
   PSGOEV       %XY^%RCR,DIE,DIR,PSGAL5,NEWUDAL^PSGAL5,$$DDOK^PSGOE2
                $$OIOK^PSGOE2,$$CHECK^PSGOE8,ENDRG^PSGOEF1,EXPOE^PSGOER
                ORSET^PSGOETO1,PSGOT,START^PSGOTR,EN^PSGPEN,DW^PSGS0,ENOS^PSGS0
                ENDDC^PSGSICHK,ENL^PSGVDS,NEWJ^PSJADM,PROFILE^PSJBLDOC
                VFY^PSJCOM
                DOSECHK^PSJDOSE,SETVAR^PSJDOSE,EN1^PSJHL2,NOTIFY^PSJHL4
                $$GETDUR^PSJLIVMD,REQDT^PSJLIVMD,$$LASTREN^PSJLMPRI
                SETOC^PSJNEWOC,IN^PSJOCDS,CLOZSND^PSJOE,UNL^PSSLOCK
                MAIN^TIUEDIT,EN^VALM,FULL^VALM1,PAUSE^VALM1
   PSGOT        EN1^DIK,SETUDINT^PSGSICH1,ENL^PSGVDS,CIMOU^PSJIMO1
                SPSPA^PSJXRFS,LOGDFN^PSUHL,$$PATCH^XPDUTL
   PSGPEN       NOW^%DTC,DIE,DIR,$$ENDTC^PSGMI,$$DEFON^PSGPER1,PSGPL0
                $$LASTREN^PSJLMPRI,$$DATE2^PSJUTL2,$$DT^XLFDT
   PSJCLOLS     %DT,%ZIS,%ZISC,%ZTLOAD
   PSJCLOZ      DD^%DT,NOW^%DTC,@(,FILE^DICN,DIE,$$GET1^DIQ,DIR,PHGRP^PSOCLO1
                SETUP^XQALERT,$$DEA^XUSER
   PSJCOM       NOW^%DTC,%XY^%RCR,DIR,NEWNVAL^PSGAL5,$$ENDTC^PSGMI
                ENWALL^PSGNE3,$$DDOK^PSGOE2,FILESI^PSJBCMA5,DOSECHK^PSJDOSE
                SETVAR^PSJDOSE,$$GETDUR^PSJLIVMD,SETOC^PSJNEWOC,MAIN^TIUEDIT
                PAUSE^VALM1
   PSJOE        HOME^%ZIS,DIR,EN1^ORCFLAG,ENQL^PSGLW,PSGOD,$$ENACTION^PSGOE1
                H^PSGOE1,ENO^PSGOEC,ABORT^PSGOEE,ACT^PSGOEE,ENF^PSGOEE
                ENSFE^PSGOEE0,FINISH^PSGOEF,START^PSGOEF,ENLM^PSGOEL,PSGOER
                PSGOERI,ORSET^PSGOETO1,ENASR^PSGON,ENCHK^PSGON,PSGPER,PSGPER1
                ENCV^PSGSETU,ENIVKV^PSGSETU,COPY^PSIVOD,H^PSIVOPT,VF^PSIVORC2
                PSIVXU,PSJAC,ENIV^PSJAC,WP^PSJAC,PSJFILE^PSJCLOZ,PSJHVARS
                RESTORE^PSJHVARS,EN^PSJLIFN,EN^PSJLIORD,REQDT^PSJLIVMD
                GETUD^PSJLMGUD,INIT^PSJLMUDE,$$HIDDEN^PSJLMUTL
                $$OINAME^PSJLMUTL
                SETOC^PSJNEWOC,DONE^PSJOE,LOCKERR^PSJOE,OLDCOM^PSJOE0
                SELECT^PSJOEA,PSJP,$$L^PSSLOCK,$$LS^PSSLOCK,UL^PSSLOCK
                UNL^PSSLOCK,$$SDIMO^SDAMA203,INP^VADPT,EN^VALM,FULL^VALM1
                PAUSE^VALM1,$$PATCH^XPDUTL,INPSND^YSCLTST5
   PSJOE1       YN^DICN,DIR,$$ENDD^PSGMI,$$ENDTC^PSGMI,$$ENNPN^PSGMI,PSGOE1
                PSGOE3,PSGOE4,PSGOE7,CHKDD^PSGOEE,EDIT^PSGOEE,GTSTATUS^PSGOEE
                ENNOU^PSGOEE0,ENSFE^PSGOEE0,PSGOES,PSGOETO,CHK^PSGOEV,EN^PSGPEN
                ENDDC^PSGSICHK,GETUD^PSJLMGUD,INIT^PSJLMUDE,$$OINAME^PSJLMUTL
                $$DD53P45^PSJMISC,SETOC^PSJNEWOC,IN^PSJOCDS,CLOZSND^PSJOE
                $$ENNOO^PSJUTL5,EN^VALM,FULL^VALM1
   PSJRXLAB     %DT,%ZIS,%ZISC,%ZTLOAD,DIC,EN^DIQ1,DIR,PID^VADPT,$$SITE^VASITE
   |dd53.8      %DT
   |opt         ENUUEP^PSGFILD0,ENCPDD^PSGFILED,PSGL,ENAL^PSGLBA,PSGOE,PSGOECA
                EN^PSGOEHA,PSGPR,PSGSET,BRJCHK^PSGSET,ENKV^PSGSETU,PSGVBW
                PSJCLOLS,START^PSJCLOR,EN^PSJOE,PSJPR,PSJRXLAB,PSSDGCK^PSJUTL1
                AGAIN^PSOCLUTL,REG^PSOCLUTL,KILL^XUSCLEAN

Routine             is Invoked by:
   ^%DT                PSGOE41,PSGOE81,PSGOER0,PSJCLOLS,PSJRXLAB,|dd53.8
   DD^%DT              PSJCLOZ
   ^%DTC               PSGOE41,PSGOE81
   C^%DTC              PSGNE3,PSGOE41,PSGOE81
   DW^%DTC             PSGNE3
   H^%DTC              PSGNE3
   NOW^%DTC            PSGNE3,PSGOEF,PSGOER,PSGOESF,PSGPEN,PSJCLOZ,PSJCOM
   YMD^%DTC            PSGNE3
   %XY^%RCR            PSGOEV,PSJCOM
   ^%ZIS               PSJCLOLS,PSJRXLAB
   HOME^%ZIS           PSJOE
   ^%ZISC              PSJCLOLS,PSJRXLAB
   ENDR^%ZISS          PSGOEF
   ^%ZTLOAD            PSJCLOLS,PSJRXLAB
   ^@(                 PSGOE7,PSJCLOZ
   EN^DDIOL            PSGOE81
   ^DIC                PSGOE42,PSGOE7,PSGOE8,PSGOE82,PSGOE92,PSGOER0,PSJRXLAB
   MIX^DIC1            PSGOE7,PSGOE8
   FILE^DICN           PSGOER,PSJCLOZ
   YN^DICN             PSGOD,PSGOE41,PSGOE42,PSGOE7,PSGOE8,PSGOE81,PSGOE82
                       PSGOE92,PSJOE1
   ^DIE                PSGOE42,PSGOE82,PSGOE92,PSGOER,PSGOESF,PSGOEV,PSGPEN
                       PSJCLOZ
   EN^DIK              PSGNE3
   EN1^DIK             PSGOT
   $$GET1^DIQ          PSJCLOZ
   EN^DIQ1             PSJRXLAB
   ^DIR                PSGOD,PSGOE7,PSGOEF,PSGOER,PSGOESF,PSGOEV,PSGPEN,PSJCLOZ
                       PSJCOM,PSJOE,PSJOE1,PSJRXLAB
   EN1^ORCFLAG         PSJOE
   $$EN^PSBAPIPM       PSGNE3,PSGOER
   ^PSGAL5             PSGOER,PSGOEV
   NEWNVAL^PSGAL5      PSJCOM
   NEWUDAL^PSGAL5      PSGOE92,PSGOEV
   $$ENDL^PSGDL        PSGOE41,PSGOE81,PSGOER0
   EN1^PSGDL           PSGNE3,PSGOE41
   ENE^PSGDL           PSGOE81
   ENGO^PSGDL          PSGOER0
   ENPREV^PSGDL        PSGOE41,PSGOE81
   ENUUEP^PSGFILD0     |opt
   ENCPDD^PSGFILED     |opt
   ^PSGL               |opt
   ENAL^PSGLBA         |opt
   ENQL^PSGLW          PSJOE
   $$ENDD^PSGMI        PSGNE3,PSGOD,PSGOE41,PSGOE81,PSGOEF,PSGOER0,PSJOE1
   $$ENDDN^PSGMI       PSGOE7
   $$ENDTC^PSGMI       PSGOD,PSGOE81,PSGOEF,PSGPEN,PSJCOM,PSJOE1
   $$ENLU^PSGMI        PSGOE8
   $$ENMRN^PSGMI       PSGOESF
   $$ENNPN^PSGMI       PSGOD,PSJOE1
   $$ENPDN^PSGMI       PSGOESF
   $$ENSTN^PSGMI       PSGOE8
   ^PSGNE3             PSGOD,PSGOE41
   $$ENSD^PSGNE3       PSGOEF,PSGOER0
   ENFD^PSGNE3         PSGOE41,PSGOEF,PSGOER0
   ENWALL^PSGNE3       PSGOER0,PSGOESF,PSJCOM
   ^PSGOD              PSJOE
   ^PSGOE              |opt
   ^PSGOE1             PSGOD,PSJOE1
   $$ENACTION^PSGOE1   PSJOE
   H^PSGOE1            PSJOE
   $$DDOK^PSGOE2       PSGOER0,PSGOEV,PSJCOM
   $$OIOK^PSGOE2       PSGOEV
   ^PSGOE3             PSJOE1
   ^PSGOE4             PSJOE1
   1^PSGOE42           PSGOE41
   GTST^PSGOE6         PSGOEF
   ^PSGOE7             PSJOE1
   $$GTNEDFD^PSGOE7    PSGOD,PSGOE8,PSGOEF,PSGOER0
   $$CHECK^PSGOE8      PSGOEV
   CLOZPRV^PSGOE82     PSGOE92,PSGOER0
   DDOC^PSGOE82        PSGOE92
   ENFF^PSGOE82        PSGOE8,PSGOE81
   ENO^PSGOEC          PSJOE
   ^PSGOECA            |opt
   ABORT^PSGOEE        PSGOEF,PSGOER,PSJOE
   ACT^PSGOEE          PSJOE
   CHKDD^PSGOEE        PSJOE1
   DONE1^PSGOEE        PSGOEF
   EDIT^PSGOEE         PSJOE1
   ENF^PSGOEE          PSJOE
   GTSTATUS^PSGOEE     PSJOE1
   NEW3^PSGOEE         PSGOEF
   ENNOU^PSGOEE0       PSJOE1
   ENSFE^PSGOEE0       PSGOD,PSGOEF,PSJOE,PSJOE1
   ^PSGOEF             PSGOEF
   FINISH^PSGOEF       PSJOE
   START^PSGOEF        PSJOE
   $$ENIVUD^PSGOEF1    PSGOEF
   ENDRG^PSGOEF1       PSGOE8,PSGOEF,PSGOER0,PSGOEV
   UPD^PSGOEF1         PSGOEF
   OVERLAP^PSGOEF2     PSGOEF
   EN^PSGOEHA          |opt
   ENLM^PSGOEL         PSJOE
   ENFF^PSGOEM         PSGOE41,PSGOE42,PSGOE81
   ENHLP^PSGOEM        PSGOE41,PSGOE42,PSGOE8,PSGOE81,PSGOE82,PSGOE92,PSGOER0
   ^PSGOER             PSJOE
   EXPOE^PSGOER        PSGOEV
   NEWOC55^PSGOER      PSGOER0
   DATE^PSGOER0        PSGOER,PSGOESF
   ^PSGOERI            PSJOE
   HMSG^PSGOERS        PSGOESF
   ^PSGOES             PSJOE1
   OC531^PSGOESF       PSGOEF
   ^PSGOETO            PSGOD,PSJOE1
   ORSET^PSGOETO1      PSGOEV,PSJOE
   CHK^PSGOEV          PSGOD,PSJOE1
   EN^PSGOEV           PSGOESF
   ENASR^PSGON         PSJOE
   ENCHK^PSGON         PSJOE
   SET^PSGON           PSGOESF
   EN^PSGORS0          PSGOEF
   ^PSGOT              PSGOEV
   START^PSGOTR        PSGOEV
   EN^PSGPEN           PSGOD,PSGOER,PSGOEV,PSJOE1
   ^PSGPER             PSJOE
   ^PSGPER1            PSGOESF,PSJOE
   $$DEFON^PSGPER1     PSGPEN
   ^PSGPL0             PSGPEN
   ^PSGPR              |opt
   $$ODD^PSGS0         PSGOE41,PSGOE81,PSGOEF
   $$PRNOK^PSGS0       PSGOE8,PSGOE81,PSGOEF,PSGOER
   DW^PSGS0            PSGOER,PSGOEV
   EN^PSGS0            PSGOE8
   ENCHK^PSGS0         PSGOE41,PSGOE81
   ENOS^PSGS0          PSGOD,PSGOEF,PSGOEV
   NSSCONT^PSGS0       PSGOEF
   ^PSGSET             |opt
   BRJCHK^PSGSET       |opt
   ENCV^PSGSETU        PSJOE
   ENIVKV^PSGSETU      PSJOE
   ENKV^PSGSETU        |opt
   SETUDINT^PSGSICH1   PSGOT
   ENDDC^PSGSICHK      PSGOD,PSGOE7,PSGOER,PSGOESF,PSGOEV,PSJOE1
   ^PSGVBW             |opt
   ENL^PSGVDS          PSGOEV,PSGOT
   ENPOS^PSGVDS        PSGOER
   COPY^PSIVOD         PSJOE
   H^PSIVOPT           PSJOE
   VF^PSIVORC2         PSJOE
   $$CODES2^PSIVUTL    PSGOE82,PSGOE92
   $$DOW^PSIVUTL       PSGOE8,PSGOER
   ^PSIVXU             PSJOE
   ^PSJAC              PSJOE
   ENIV^PSJAC          PSJOE
   WP^PSJAC            PSJOE
   NEWJ^PSJADM         PSGOEV
   $$DIFFSI^PSJBCMA5   PSGOE81
   $$EDITSI^PSJBCMA5   PSGOE41,PSGOE81
   FILESI^PSJBCMA5     PSJCOM
   KILL^PSJBCMA5       PSGOE7
   PROFILE^PSJBLDOC    PSGOEV
   ^PSJCLOLS           |opt
   START^PSJCLOR       |opt
   CLOZ^PSJCLOZ        PSGOD,PSGOE8,PSGOEF,PSGOER
   PROVCHK^PSJCLOZ     PSGOE42,PSGOE82
   PSJFILE^PSJCLOZ     PSJOE
   VFY^PSJCOM          PSGOEV
   CMPLX^PSJCOM1       PSGOE92
   ^PSJCOMR            PSGOER
   $$DSTART^PSJDCU     PSGOEF
   $$ENOSD^PSJDCU      PSGNE3,PSGOE41,PSGOER0
   $$DGCKIEN^PSJDGCK   PSGOE7
   $$PSJSUPCK^PSJDGCK  PSGOE7
   DIN^PSJDIN          PSGOE7
   DOSECHK^PSJDOSE     PSGOE82,PSGOE92,PSGOEF,PSGOEV,PSJCOM
   DSPWARN^PSJDOSE     PSGOE82,PSGOE92
   EDITDOSE^PSJDOSE    PSGOE8
   SETVAR^PSJDOSE      PSGOEV,PSJCOM
   EN1^PSJHL2          PSGOER,PSGOEV
   NOTIFY^PSJHL4       PSGOEV
   ^PSJHVARS           PSJOE
   RESTORE^PSJHVARS    PSJOE
   CIMOU^PSJIMO1       PSGOT
   EN^PSJLIFN          PSJOE
   EN^PSJLIORD         PSJOE
   $$SCHREQ^PSJLIVFD   PSGOER
   $$DURMIN^PSJLIVMD   PSGNE3,PSGOE81,PSGOEF,PSGOER0
   $$GETDUR^PSJLIVMD   PSGNE3,PSGOE81,PSGOEF,PSGOER0,PSGOEV,PSJCOM
   REQDT^PSJLIVMD      PSGOEF,PSGOEV,PSJOE
   GETUD^PSJLMGUD      PSGOD,PSGOEF,PSJOE,PSJOE1
   $$LASTREN^PSJLMPRI  PSGOE81,PSGOE82,PSGOEF,PSGOEV,PSGPEN
   INIT^PSJLMUDE       PSGOD,PSGOEF,PSJOE,PSJOE1
   PAUSE^PSJLMUT1      PSGOER
   $$DRUGNAME^PSJLMUTL PSGOESF
   $$HIDDEN^PSJLMUTL   PSGOESF,PSJOE
   $$OINAME^PSJLMUTL   PSGOD,PSGOE7,PSGOE8,PSGOEF,PSJOE,PSJOE1
   $$DD53P45^PSJMISC   PSGOEF,PSGOESF,PSJOE1
   SETOC^PSJNEWOC      PSGOD,PSGOER,PSGOEV,PSJCOM,PSJOE,PSJOE1
   ALLERGY^PSJOC       PSGOE82
   IN^PSJOCDS          PSGOD,PSGOEF,PSGOER,PSGOESF,PSGOEV,PSJOE1
   $$COMPLEX^PSJOE     PSGOE92
   CLOZSND^PSJOE       PSGOEV,PSJOE1
   DONE^PSJOE          PSJOE
   EN^PSJOE            |opt
   LOCKERR^PSJOE       PSJOE
   OLDCOM^PSJOE0       PSJOE
   OC^PSJOE1           PSGOEF
   SELECT^PSJOEA       PSJOE
   ENUDTX^PSJOREN      PSGOER
   $$ENQ^PSJORP2       PSGNE3,PSGOE41,PSGOE81,PSGOER
   $$LASTAT^PSJORP2    PSGOER
   ADMIN^PSJORPOE      PSGOER
   $$ACTIVE^PSJORREN   PSGOER,PSGOER0
   ^PSJP               PSJOE
   ^PSJPR              |opt
   ^PSJRXLAB           |opt
   $$ENBCMA^PSJUTL     PSGOE41,PSGOE81
   $$ENPC^PSJUTL       PSGOEF
   EFDNEW^PSJUTL       PSGOE41,PSGOER0
   EFDNV^PSJUTL        PSGOE81
   READ^PSJUTL         PSGOE7
   PSSDGCK^PSJUTL1     |opt
   $$DATE^PSJUTL2      PSGNE3,PSGOER
   $$DATE2^PSJUTL2     PSGNE3,PSGOER,PSGOER0,PSGPEN
   $$ENNOO^PSJUTL5     PSGOD,PSGOEF,PSGOER0,PSJOE1
   SPSPA^PSJXRFS       PSGOT
   $$PROD0^PSNAPIS     PSGOE7
   PHGRP^PSOCLO1       PSJCLOZ
   AGAIN^PSOCLUTL      |opt
   REG^PSOCLUTL        |opt
   $$L^PSSLOCK         PSJOE
   $$LS^PSSLOCK        PSGOER,PSGOESF,PSJOE
   UL^PSSLOCK          PSJOE
   UNL^PSSLOCK         PSGOER,PSGOESF,PSGOEV,PSJOE
   DOSE^PSSORPH        PSGOEF
   LOGDFN^PSUHL        PSGOT
   $$SDIMO^SDAMA203    PSJOE
   MAIN^TIUEDIT        PSGOEV,PSJCOM
   INP^VADPT           PSGOD,PSJOE
   PID^VADPT           PSJRXLAB
   EN^VALM             PSGOD,PSGOEF,PSGOEV,PSJOE,PSJOE1
   REFRESH^VALM        PSGOEF
   FULL^VALM1          PSGOD,PSGOE92,PSGOEF,PSGOESF,PSGOEV,PSJOE,PSJOE1
   PAUSE^VALM1         PSGOD,PSGOE8,PSGOE81,PSGOE82,PSGOE92,PSGOER,PSGOESF
                       PSGOEV,PSJCOM,PSJOE
   RE^VALM4            PSGOEF
   $$SITE^VASITE       PSJRXLAB
   $$DT^XLFDT          PSGPEN
   $$FMADD^XLFDT       PSGNE3,PSGOE81,PSGOEF,PSGOER,PSGOER0
   $$FMDIFF^XLFDT      PSGNE3
   $$NOW^XLFDT         PSGOEF,PSGOER0
   $$PATCH^XPDUTL      PSGOT,PSJOE
   SETUP^XQALERT       PSJCLOZ
   KILL^XUSCLEAN       |opt
   $$DEA^XUSER         PSJCLOZ
   INPSND^YSCLTST5     PSJOE

*****   END   *****


--- END ---
VISTAS1:VISTA>

